Celestin Apprentice 2/Apprentice-Release2.iso/Tools/Languages/MacMETH 3.2.1/Sources/MacC3.3/M2HA40.MOD

Modula Implementation | 1992-05-29 | 83.6 KB | 2,590 lines | [TEXT/MEDT]

IMPLEMENTATION MODULE M2HA; (* Hermann Seiler 19.4.85 / 1.7.86 / 19.12.91 / 29.5.92 *)

  (* Implementation for the MOTOROLA MC68040 processors. *)

  FROM SYSTEM IMPORT
     WORD, LONG, LSH, VAL;
  FROM M2SA IMPORT
     Symbol, Mark;
  FROM M2DA IMPORT
     ObjPtr, StrPtr, StrForm, ConstValue, PDesc,
     Object, Structure, Standard,
     notyp, undftyp, booltyp, chartyp, inttyp,
     bitstyp, dbltyp, realtyp, lrltyp, proctyp,
     stringtyp, addrtyp, bytetyp,
     WordSize, MinInt, MaxInt, MaxDouble, NilVal,
     rngchk, ovflchk;
  FROM M2LA IMPORT
     pc, maxP, maxM, PutWord, PutLong, FixLink;


  CONST

     (* Register usage and dedicated registers :   *)
     (* D-Register pool for expression evaluation. *)

(*   D0  = 0;   (* freely used, never reserved *)
     D1  = 1;   (* freely used, never reserved *)  *)
     D2  = 2;   (* D-pool, reserved when used  *)
     D3  = 3;   (* D-pool, reserved when used  *)
     D4  = 4;   (* D-pool, reserved when used  *)
     D5  = 5;   (* D-pool, reserved when used  *)
     D6  = 6;   (* D-pool, reserved when used  *)
     D7  = 7;   (* D-pool, reserved when used  *)

     (* F-Register pool for floating point arith.  *)

(*   F0  = 0;   (* freely used, never reserved *)
     F1  = 1;   (* freely used, never reserved *)  *)
     F2  = 2;   (* F2 - F7 reserved when used  *)
     F7  = 7;

     (* A-Register pool for address calculations.  *)

     A0  = 0;   (* A-pool, reserved when used  *)
     A1  = 1;   (* A-pool, reserved when used  *)
     A2  = 2;   (* A-pool, reserved when used  *)
     A3  = 3;   (* A-pool, reserved when used  *)

(*
     (* Dedicated A-Registers. *)

     SB  = 4;   (* SB = A4 : static base pointer   *)
     A5  = 5;   (* A5 is   n e v e r   used !      *)
     MP  = 6;   (* MP = A6 : procedure mark        *)
     SP  = 7;   (* SP = A7 : active stack pointer  *)

     (* Instruction size for simple types. *)

     byte  =  0;  word  =  1;  long  =  2;

     (* Descriptor size dynamic array parameters.  *)

     DynArrDesSize = 6;
*)

     (* Addressing Mode Categories. *)

     DDIR     = 0;       (* D-Reg. direct  *)
     ADIR     = 10B;     (* A-Reg. direct  *)
     AIDR     = 20B;     (*     (An)       *)
     AINC     = 30B;     (*     (An)+      *)
     ADEC     = 40B;     (*    -(An)       *)
     AOFF     = 50B;     (*  d16(An)       *)
     AIDX     = 60B;     (*   d8(An,Rx)    *)
     XXXW     = 70B;     (* absolute short *)
     XXXL     = 71B;     (* absolute long  *)
     PREL     = 72B;     (*  d16(PC)       *)
     IMM      = 74B;     (* immediate or SR*)


     (* MC68000 instruction mnemonics. *)
     (* _____________________________  *)

     (* Special purpose. *)
     UNLK     = 047136B; (* UNLK MP *)
     LINK     = 047126B; (* LINK MP,#d16 *)
     LEASP    = 047757B; (* LEA d16(SP),SP *)
     INCSP    = 050217B; (* ADDQ.L #n,SP *)
     DECSP    = 050617B; (* SUBQ.L #n,SP *)
     MOVEMDEC = 044347B; (* MOVEM.L registers,-(SP) *)
     MOVEMINC = 046337B; (* MOVEM.L (SP)+,registers *)
     MVEMSP   = 027400B; (* MOVE.L  ea,-(SP) : push *)
     MVESPP   = 020037B; (* MOVE.L  (SP)+,ea : pop  *)
     PUSHSB   = 027410B + SB;       (* MOVE.L  SB,-(SP) *)
     POPSB    = 020137B + SB*1000B; (* MOVEA.L (SP)+,SB *)

     (* Instructions without operand. *)
     NOP  = 047161B; RTE  = 047163B;
     RTS  = 047165B; RTD  = 047164B; (* MC68010 *)
     TRAPV= 047166B; ILL  = 045374B;

     (* Branches : with a displacement. *)
     BRA  = 060000B; BSR  = 060400B;
     BHI  = 061000B; BLS  = 061400B; BCC  = 062000B; BCS  = 062400B;
     BNE  = 063000B; BEQ  = 063400B; BVC  = 064000B; BVS  = 064400B;
     BPL  = 065000B; BMI  = 065400B; BGE  = 066000B; BLT  = 066400B;
     BGT  = 067000B; BLE  = 067400B;

     (* Branches : a register and a displacement. *)
     DBT  = 050310B; DBRA = 050710B;
     DBHI = 051310B; DBLS = 051710B; DBCC = 052310B; DBCS = 052710B;
     DBNE = 053310B; DBEQ = 053710B; DBVC = 054310B; DBVS = 054710B;
     DBPL = 055310B; DBMI = 055710B; DBGE = 056310B; DBLT = 056710B;
     DBGT = 057310B; DBLE = 057710B;

     (* Set according to condition an effective address. *)
     ST   = 050300B;

     (* Operand is a specific register. *)
     SWAP = 044100B;
     EXTW = 044200B; (* EXT.W byte to word *)
     EXTL = 044300B; (* EXT.L word to long *)

     (* Operand is an effective address. *)
     CLR  = 041000B; NEG  = 042000B;
     TST  = 045000B; COM  = 043000B; (* synonym for NOT *)
     JMP  = 047300B; JSR  = 047200B;
     PEA  = 044100B; TAS  = 045300B;
     INC1 = 051000B; (* ADDQ #1,ea *)
     DEC1 = 051400B; (* SUBQ #1,ea *)

     (* Operand is an immediate value. *)
     TRAP = 047100B; (* TRAP #vector *)
     EMUF = 170000B; (* Line F *)
     EMUA = 120000B; (* Line A *)

     (* Operands are a register and an effective address. *)
     ADD  = 150000B; SUB  = 110000B;
     CMP  = 130000B; EORL = 130400B; (* synonym for exclusive OR *)
     ANDL = 140000B; (* synonym for AND *)
     ORL  = 100000B; (* synonym for inclusive OR *)
     CHK  = 040600B; LEA  = 040700B;
     DIVS = 100700B; DIVU = 100300B;
     MULS = 140700B; MULU = 140300B;
     ADDAW= 150300B; (* ADDA.W ea,An *)
     ADDAL= 150700B; (* ADDA.L ea,An *)
     CMPAL= 130700B; (* CMPA.L ea,An *)
     SUBAL= 110700B; (* SUBA.L ea,An *)
     EXGL = 140500B; (* EXG.L  Dn,Dm *)

     (* Immediate data within op. and an effective address. *)
     ADDQ = 050000B; SUBQ = 050400B;

     (* Shift register by count. *)
     ASL  = 160400B; ASR  = 160000B; LSL  = 160410B; LSR  = 160010B;
     ROL  = 160430B; ROR  = 160030B;

     (* Immediate data within extension and an effective address. *)
     ADDI = 003000B; ANDI = 001000B; CMPI = 006000B;
     EORI = 005000B; ORI  = 000000B; SUBI = 002000B;

     (* Bit manipulation. *)
     BTST = 000400B; BCHG = 000500B; BCLR = 000600B; BSET = 000700B;

     (* Move groups. *)
     MOVEB     = 010000B; (* group 1 *)
     MOVEW     = 030000B; (* group 3 *)
     MOVEL     = 020000B; (* group 2 *)
     MOVEAW    = 030100B; (* MOVEA.W ea,An *)
     MOVEAL    = 020100B; (* MOVEA.L ea,An *)
     MOVEQ     = 070000B; (* MOVE.L #imm,Dn *)
     MOVEFRCCR = 041300B; (* MOVE.W CCR,ea *)
     MOVETOCCR = 042300B; (* MOVE.W ea,CCR *)

     (* MC68040 instruction supplement for integer unit. *)
     CHKL      = 040400B; (* CHK long *)
     DIVL      = 046100B; (* 32/32  -->  32r:32q *)
     EXTBL     = 044700B; (* extend byte to long *)
     MULL      = 046000B; (* 32*32  -->  32 *)
     TRAPEQ    = 053774B; (* TRAP on EQ *)

     (* MC68040 instruction supplement for floating-point unit. *)
     FGEN      = 171000B; (* general operation *)
     FTRAPcc   = 171174B; (* no operand following *)
     FST       = 171100B; (* FScc *)
     FBRA      = 171200B; (* FBcc, size = word *)
     FMOVEMDEC = 171047B; (* FMOVEM regs,-(SP) *)
     FMOVEMD2  = 160000B; (* static list, predecrement  *)
     FMOVEMINC = 171037B; (* FMOVEM (SP)+,regs *)
     FMOVEMI2  = 150000B; (* static list, postincrement *)
     FMOVEtoCR = 110000B; (* op-code/op-class for FMOVE to FPCR *)

     (* MC68040 instruction op-classes. *)
     FtoF      = 0;       (* FPm  to FPn  *)
     EAtoF     = 40000B;  (* <ea> to FPn  *)
     FtoEA     = 60000B;  (* FPn  to <ea> *)
     EAtoCR    = 110000B; (* <ea> to FPCR *)
     CRtoEA    = 130000B; (* FPCR to <ea> *)

     (* MC68040 floating point operation codes. *)
     FMOVE     = 0;     FABS      = 18H;   FNEG      = 1AH;   FSQRT     = 04H;
     FADD      = 22H;   FSUB      = 28H;   FMUL      = 23H;   FDIV      = 20H;
     FTST      = 3AH;   FCMP      = 38H;

     (* concerning the STATUS register. *)
     NBIT      = 8;       (* negative bit *)
     ZBIT      = 4;       (* zero bit *)
     VBIT      = 2;       (* overflow bit *)
     CBIT      = 1;       (* carry bit *)

     (* Left shift constants. *)
     LS3  =  10B;  LS4  =  20B;  LS5  =  40B;   LS6  =  100B;
     LS7  = 200B;  LS8  = 400B;  LS9  =  1000B; LS10 =  2000B;
     LS11 = 4000B; LS12 = 10000B;

     (* System procedure numbers used by the compiler : *)
     BodyOfSystem        = 0; (* 0 is reserved for module body *)
     HALTX               = 1; (* System.HALTX = HALT-statement *)


  VAR

     Rpool, Rbusy, Rlock : BITSET;
     FRpool, FRbusy      : BITSET;
     MoveCode            : ARRAY WidType OF INTEGER;
     ShiCode             : ARRAY [ Asl .. Ror ] OF INTEGER;
     mask                : ARRAY [ 0 .. 32 ] OF LONGINT;
     hightyp             : StrPtr;

  PROCEDURE ProcessorID(VAR id: Processor);
  BEGIN
    id := "MC68040"
  END ProcessorID;

  PROCEDURE err(n : INTEGER);
    (* local synonym for M2SM.Mark to save space! *)
  BEGIN
    Mark(n);
  END err;

  PROCEDURE Put16(w : WORD);
    (* local synonym for M2LM.PutWord to save space! *)
  BEGIN
    PutWord(w);
  END Put16;

  PROCEDURE Put32(l : LONGINT);
    (* local synonym for M2LM.PutLong to save space! *)
  BEGIN
    PutLong(l);
  END Put32;

  PROCEDURE SignedT(VAR x : Item) : BOOLEAN;
    (*      is x a signed type ?       *)
    (* Note :  Real/LongReal excluded! *)
    VAR s : StrPtr;
  BEGIN
    s := x.typ; (* let x.typ unchanged *)
    WHILE s^.form = Range DO s := s^.RBaseTyp END;
    RETURN (s = inttyp) OR (s = dbltyp)
  END SignedT;

  PROCEDURE SimpleT(VAR x : Item) : BOOLEAN;
    (*   is x a simple type of size   *)
    (*         byte/word/long ?       *)
    (* Note : Real/LongReal excluded! *)
    VAR f : StrForm; s : StrPtr; sz : INTEGER;
  BEGIN
    s := x.typ; (* let x.typ unchanged *)
    WHILE s^.form = Range DO s := s^.RBaseTyp END;
    f := s^.form; sz := s^.size;
    RETURN (sz IN {1,2,4}) AND ((f <= Double) OR (f = Pointer) OR
            (f = Set) OR (f = ProcTyp) OR (f = Opaque))
  END SimpleT;

  PROCEDURE RealT(VAR x : Item) : BOOLEAN;
    (*  is x a floating-point-type ?  *)
    (*       (REAL or LONGREAL)       *)
    (* Note: floating-point-types are *)
    (*       NOT considered as simple *)
    VAR s : StrPtr;
  BEGIN
    s := x.typ; (* let x.typ unchanged *)
    RETURN (s = realtyp) OR (s = lrltyp)
  END RealT;

  PROCEDURE SimpleC(VAR x : Item) : BOOLEAN;
    (* is x a simple constant of size *)
    (*         byte/word/long ?       *)
    (* Note : Real/LongReal excluded! *)
  BEGIN
    RETURN (x.mode = conMd) & SimpleT(x)
  END SimpleC;

  PROCEDURE LongVal(VAR x : Item) : LONGINT;
    VAR r : LONGINT;
  BEGIN r := 0D;
    WITH x DO
      WHILE typ^.form = Range DO typ := typ^.RBaseTyp END;
      CASE typ^.form OF
        Undef :        r := val.U;
      | Byte :         r := LONG(val.Ch);
      | Bool :         r := LONG(val.B);
      | Char :         r := LONG(val.Ch);
      | Int :          r := LONG(val.I);
      | Enum :         r := LONG(val.Ch);
      | Word :         r := LONG(0, val.I);
      | LWord :        r := val.D;
      | Double :       r := val.D;
      | Real :         r := VAL(LONGINT, val.R);
      | Set :          r := VAL(LONGINT, val.S);
      ELSE             r := val.D; (* String, etc. *)
      END;
    END (*WITH*);
    RETURN r
  END LongVal;

  PROCEDURE WordVal(VAR x : Item) : INTEGER;
    VAR r : INTEGER;
  BEGIN r := 0;
    WITH x DO
      WHILE typ^.form = Range DO typ := typ^.RBaseTyp END;
      CASE typ^.form OF
        Undef :        r := VAL(INTEGER, val.U);
      | Byte :         r := ORD(val.Ch);
      | Bool :         r := ORD(val.B);
      | Char :         r := ORD(val.Ch);
      | Int :          r := val.I;
      | Enum :         r := ORD(val.Ch);
      | Word :         r := val.I;
      | LWord :        r := VAL(INTEGER, val.D);
      | Double :       r := VAL(INTEGER, val.D);
      | Real :         r := VAL(INTEGER, VAL(LONGINT, val.R));
      | Set :          r := VAL(INTEGER, val.S);
      ELSE             r := VAL(INTEGER, val.D); (* String, etc. *)
      END;
    END (*WITH*);
    RETURN r
  END WordVal;

  PROCEDURE ZeroVal(VAR x : Item) : BOOLEAN;
    VAR b : BOOLEAN;
  BEGIN b := FALSE;
    IF x.mode = conMd THEN
      IF    x.typ = realtyp THEN b := x.val.R = FLOAT(0)
      ELSIF x.typ = lrltyp  THEN b := x.val.X = FLOATD(0)
      END;
    END;
    RETURN b
  END ZeroVal;

  PROCEDURE Iea(fea : INTEGER) : INTEGER;
    (* invert the 'mode/register' effective address *)
    (* to 'register/mode' representation.           *)
  BEGIN
    RETURN (fea MOD 8)*8 + (fea DIV 8)
  END Iea;

  PROCEDURE Isz(VAR x : Item; VAR fsz : WidType);
    (* instruction size for item x : byte/word/long. *)
    (* Note :  callable only for simple types !      *)
    VAR s : INTEGER; sz : WidType;
  BEGIN
    s := x.typ^.size;
    IF    s = 1 THEN sz := byte
    ELSIF s = 2 THEN sz := word
    ELSIF s = 4 THEN sz := long
    ELSE sz := long; err(238); (* invalid instruction size *)
    END;
    fsz := sz
  END Isz;

  PROCEDURE SetglbMd(VAR x : Item; fadr : INTEGER; ftyp : StrPtr);
    (* setup of an item designating a global variable *)
  BEGIN
    WITH x DO
      IF ftyp # NIL THEN typ := ftyp ELSE typ := undftyp END;
      mode := RindMd;  mod := 0;   lev   := 0;
      adr  := fadr;    off := 0;   indir := FALSE;
      R    := SB + 8;
    END (*WITH*);
  END SetglbMd;

  PROCEDURE SetlocMd(VAR x : Item; fadr : INTEGER; ftyp : StrPtr);
    (* setup of an item which is relative to the Marker MP *)
  BEGIN
    WITH x DO
      IF ftyp # NIL THEN typ := ftyp ELSE typ := undftyp END;
      mode := RindMd;  mod := 0;   lev   := curLev;
      adr  := fadr;    off := 0;   indir := FALSE;
      R    := MP + 8;
    END (*WITH*);
  END SetlocMd;

  PROCEDURE SetregMd(VAR x : Item; freg : Register; ftyp : StrPtr);
    (* setup of an item designating a (long) register. *)
  BEGIN
    WITH x DO
      IF ftyp # NIL THEN typ := ftyp ELSE typ := undftyp END;
      IF freg <= D7  THEN mode := DregMd ELSE mode := AregMd END;
      mod := 0;     lev := curLev;
      adr := 0;     off := 0;    indir := FALSE;
      R   := freg;  wid := long;
    END (*WITH*);
  END SetregMd;

  PROCEDURE SetstkMd(VAR x : Item; ftyp : StrPtr);
    (* setup of an item on top of stack. *)
  BEGIN
    WITH x DO
      IF ftyp # NIL THEN typ := ftyp ELSE typ := undftyp END;
      mode := stkMd;  mod := 0;   lev   := curLev;
      adr  := 0;      off := 0;   indir := FALSE;
      R    := SP + 8;
    END (*WITH*);
  END SetstkMd;

  PROCEDURE SetfltMd(VAR x : Item; fR : Register; ftyp : StrPtr);
    (* setup of an item designating a floating-point register. *)
  BEGIN
    WITH x DO
      mode := fltMd; FR := fR; typ := ftyp;
    END (*WITH*);
  END SetfltMd;

  PROCEDURE SetconMd(VAR x : Item; fval : LONGINT; ftyp : StrPtr);
    VAR v : ConstValue;
  BEGIN
    WITH x DO
      IF ftyp # NIL THEN typ := ftyp ELSE typ := undftyp END;
      WHILE typ^.form = Range DO typ := typ^.RBaseTyp END;
      mode  := conMd;
      CASE typ^.form OF
        Undef :    v.U  := fval;
      | Byte :     v.Ch := VAL(CHAR, fval);
      | Bool :     v.B  := VAL(BOOLEAN, fval);
      | Char :     v.Ch := VAL(CHAR, fval);
      | Int :      v.I  := VAL(INTEGER, fval);
      | Enum :     v.Ch := VAL(CHAR, fval);
      | Word :     v.I  := VAL(INTEGER, fval);
      | LWord :    v.D  := fval;
      | Double :   v.D  := fval;
      | Real :     v.R  := VAL(REAL, fval);
      | Set :      v.S  := VAL(BITSET, fval);
      ELSE         v.D  := fval; (* String, etc. *)
      END;
      val := v;
    END (*WITH*);
  END SetconMd;

  PROCEDURE SetbusyReg(r : Register);
  BEGIN
    IF r IN Rpool THEN INCL(Rbusy,r) END;
  END SetbusyReg;

  PROCEDURE SetbusyFReg(r : Register);
  BEGIN
    IF r IN FRpool THEN INCL(FRbusy,r) END;
  END SetbusyFReg;

  PROCEDURE SaveRegs(VAR save : LONGINT);
    (* save the busy registers and return the list *)
    (* of the saved registers in 'save'.           *)
    (*                                             *)
    (* Note : the saved registers are NOT released *)
    (* ----   and remain busy !                    *)
    (*        SP is never saved nor restored !     *)
    (*                                             *)
    VAR r, lr : Register; x, reglist, n : INTEGER;
        regs  : RECORD
                  CASE :BOOLEAN OF
                     TRUE : All : LONGINT
                   | FALSE: FPU, CPU : INTEGER
                  END
                END;
  BEGIN regs.All := 0D;
    (* the global (CPU) registers : *)
    x := 1; reglist := 0; r := SP + 8; n := 0;
    REPEAT (* from SP-1 downto D0 *)
      DEC(r); x := x + x;
      IF (r IN Rpool) & (r IN Rbusy) THEN
        INC(n); lr := r;
        reglist := reglist + x;
      END;
    UNTIL r = D0;
    IF reglist # 0 THEN
      IF n = 1 THEN Put16(MVEMSP + lr)
      ELSE Put16(MOVEMDEC); Put16(reglist) END;
    END;
    regs.CPU := reglist; (* global register set *)
    (* the floating point (FPU) registers : *)
    x := 1; reglist := 0;
    FOR r := F0 TO F7 DO (* from F0 up to F7 *)
      IF (r IN FRpool) & (r IN FRbusy) THEN
        reglist := reglist + x;
      END;
      x := x + x;
    END;
    IF reglist # 0 THEN
      Put16(FMOVEMDEC);
      Put16(FMOVEMD2 + reglist);
    END;
    regs.FPU := reglist; (* floating register set *)
    save := regs.All;
  END SaveRegs;

  PROCEDURE RestoreRegs(save : LONGINT);
    (* restore the registers given by 'save'. *)
    VAR r, lr : Register; x, reglist, n : INTEGER;
        regs  : RECORD
                  CASE :BOOLEAN OF
                     TRUE : All : LONGINT
                   | FALSE: FPU, CPU : INTEGER
                  END
                END;
  BEGIN regs.All := save;
    (* the floating point (FPU) registers : *)
    x := 128; reglist := 0;
    FOR r := F0 TO F7 DO (* from F0 up to F7 *)
      IF ODD(regs.FPU) THEN reglist := reglist + x END;
      x := LSH(x, -1); regs.FPU := LSH(regs.FPU, -1);
    END;
    IF reglist # 0 THEN
      Put16(FMOVEMINC);
      Put16(FMOVEMI2 + reglist);
    END;
    (* the global (CPU) registers : *)
    x := 8000H; reglist := 0; r := SP + 8; n := 0;
    REPEAT (* from SP-1 downto D0 *)
      DEC(r); x := LSH(x, -1); regs.CPU := LSH(regs.CPU, -1);
      IF ODD(regs.CPU) THEN
        INC(n); lr := r;
        reglist := reglist + x;
      END;
    UNTIL r = D0;
    IF reglist # 0 THEN
      IF n = 1 THEN Put16(MVESPP + Iea(lr)*LS6)
      ELSE Put16(MOVEMINC); Put16(reglist) END;
    END;
  END RestoreRegs;

  PROCEDURE Islocked(r : Register) : BOOLEAN;
  BEGIN
    RETURN (r IN Rlock)
  END Islocked;

  PROCEDURE ReleaseReg(r : Register);
  BEGIN
    IF NOT(r IN Rlock) THEN EXCL(Rbusy,r) END;
  END ReleaseReg;

  PROCEDURE LockReg(r : Register);
  BEGIN
    INCL(Rlock,r);
  END LockReg;

  PROCEDURE UnlockReg(r : Register);
    (* must be followed by ReleaseReg when r is released *)
  BEGIN
    EXCL(Rlock,r);
  END UnlockReg;

  PROCEDURE Release(VAR x : Item);
  BEGIN
    WITH x DO
      IF mode IN ItSet{RindMd,RidxMd,AregMd,DregMd} THEN
        IF R IN Rpool THEN ReleaseReg(R) END;
      ELSIF mode = fltMd THEN
        IF FR IN FRpool THEN EXCL(FRbusy,FR) END;
      END;
      IF mode = RidxMd THEN ReleaseReg(RX) END;
    END (*WITH*);
  END Release;

  PROCEDURE GetReg(VAR r : Register; qual : RegType);
    VAR hr, lr : Register;
  BEGIN
    IF qual = Areg THEN hr := A3 + 8; lr := A0 + 8
    ELSE hr := D2; lr := D7 END;
    LOOP
      IF NOT(hr IN Rbusy) THEN
        r := hr; SetbusyReg(hr); EXIT
      END;
      IF hr = lr THEN
        err(215); r := lr;    (* register overflow *)
        ReleaseReg(lr); EXIT  (* avoid endless loop *)
      END;
      IF qual = Dreg THEN
        (* D2 -> D4 -> D6 -> D3 -> D5 -> D7 *)
        IF hr = D6 THEN hr := D3
        ELSE hr := hr + 2 END
      ELSE (* qual = Areg *)
        (* A3 -> A2 -> A1 -> A0 *)
        hr := hr - 1
      END;
    END (*LOOP*);
  END GetReg;

  PROCEDURE GetFReg(VAR r : Register);
    VAR hr : Register;
  BEGIN
    hr := F2;
    LOOP
      IF NOT(hr IN FRbusy) THEN
        r := hr; SetbusyFReg(hr); EXIT
      END;
      IF hr = F7 THEN
        err(215); r := F7;     (* register overflow *)
        EXCL(FRbusy,F7); EXIT  (* avoid endless loop *)
      END;
      hr := hr + 1
    END (*LOOP*);
  END GetFReg;

  PROCEDURE InitRegs;
  BEGIN
    Rpool  := { D2 .. D7, A0+8 .. A3+8 };
    Rlock  := { SB+8 .. SP+8 };
    Rbusy  := Rlock;
    FRpool := { F2 .. F7 };
    FRbusy := {};
  END InitRegs;

  PROCEDURE CheckRegs;
  BEGIN
    IF (Rbusy # Rlock) OR (FRbusy # {}) THEN
      err(234);
      Rbusy  := Rlock;
      FRbusy := {};
    END;
  END CheckRegs;

  PROCEDURE InvertCC(cond : Condition) : Condition;
    (* generate the 'inverted' condition. *)
    VAR c : INTEGER;
  BEGIN c := ORD(cond);
    IF c < 16 THEN
      IF ODD(c) THEN DEC(cond) ELSE INC(cond) END;
    ELSE
      c := c - 16;
      c := 15 - c;
      c := c + 16;
      cond := VAL(Condition, c);
    END;
    RETURN cond
  END InvertCC;

  PROCEDURE Jf(cond : Condition; VAR l : INTEGER);
    (* jump forward, build chain. *)
    VAR c : INTEGER;
  BEGIN c := ORD(cond);
    IF c < 16 THEN
      (* MC68000 does NOT have a 'Branch on Never True' ! *)
      IF c = 1 THEN Put16(CMPI) ELSE Put16(BRA + c*LS8) END;
      Put16(l);
    ELSE
      (* FNOP is equal to 'Branch on Never True' ! *)
      Put16(FBRA + c); (* use Non-Aware Test *)
      Put16(l);
    END;
    l := pc - 2; (* location of word-displacement *)
  END Jf;

  PROCEDURE Jb(cond : Condition; l : INTEGER);
    (* jump backward, no chain. *)
    VAR c, dd : INTEGER; d : INTEGER;
  BEGIN c := ORD(cond);
    d  := l - pc - 2; dd := d;
    IF (d >= -128) & (c # 1) & (c < 16) THEN (* short branch *)
      Put16(BRA + c*LS8 + (dd MOD 256))
    ELSE
      Jf(cond,dd)
    END;
  END Jb;

  PROCEDURE Scc(cond : Condition; Dn : Register);
    (* set D-Register according to condition. *)
    VAR c : INTEGER;
  BEGIN c := ORD(cond);
    IF c < 16 THEN
      Put16(ST + c*LS8 + DDIR + Dn);
    ELSE
      Put16(FST + DDIR + Dn);
      Put16(c); (* use Non-Aware Test *)
    END;
    Put16(NEG + byte*LS6 + DDIR + Dn);
  END Scc;

  PROCEDURE LoadCC(VAR x : Item);
    (* convert from 'cocMd' to 'DregMd' while *)
    (* generating conditional code.           *)
    VAR Dn : Register;
  BEGIN
    WITH x DO
      GetReg(Dn,Dreg);
      IF (Tjmp = 0) & (Fjmp = 0) THEN
        Scc(InvertCC(CC), Dn);
        (* transform 'cocMd' to 'DregMd' *)
        SetregMd(x, Dn, booltyp);
        wid := byte;
      ELSE
        Jf(CC, Fjmp);
        FixLink(Tjmp);
        Put16(MOVEQ + Dn*LS9 + 1);
        Put16(BRA + 2);
        FixLink(Fjmp);
        Put16(MOVEQ + Dn*LS9 + 0);
        (* transform 'cocMd' to 'DregMd' *)
        SetregMd(x, Dn, booltyp);
        wid := long;
      END;
    END (*WITH*);
  END LoadCC;

  PROCEDURE ExternalCall(mno, pno : INTEGER);
    (* call of the external procedure #pno in module #mno. *)
    VAR An : Register;
  BEGIN
    GetReg(An,Areg); (* An IN { 8 .. 15 } *)
    An := An MOD 8;
    Put16(MOVEAL + An*LS9 + AOFF + SB);   (* MOVEA.L (maxP+mno)*4(SB),An *)
    Put16((maxP + mno)*4);
    IF pno = 0 THEN
      Put16(MOVEAL + An*LS9 + AIDR + An); (* MOVEA.L (An),An      *)
    ELSE
      Put16(MOVEAL + An*LS9 + AOFF + An); (* MOVEA.L pno*4(An),An *)
      Put16(pno*4);
    END;
    Put16(JSR + AIDR + An);               (* JSR (An) *)
    ReleaseReg(An + 8);
  END ExternalCall;

  PROCEDURE downlevel(VAR x : Item);
    (* for level difference >= 1. *)
    CONST offSL = 8; (* offset of Static Link *)
    VAR   N,An : Register; n : INTEGER;
  BEGIN
    GetReg(N,Areg);
    An := N MOD 8;
    Put16(MOVEAL + An*LS9 + AOFF + MP);   (* MOVEA.L offSL(MP),An *)
    Put16(offSL);
    n := curLev - x.lev;
    WHILE n > 1 DO
      DEC(n);
      Put16(MOVEAL + An*LS9 + AOFF + An); (* MOVEA.L offSL(An),An *)
      Put16(offSL);
    END;
    ReleaseReg(x.R);
    x.R := N;
  END downlevel;

  PROCEDURE Ext(VAR x : Item);
    (* effective address extension of x. *)
    VAR ext : INTEGER; sz : INTEGER;
  BEGIN
    WITH x DO
      CASE mode OF
        absMd :          Put32(adr);
      | RindMd :         IF adr # 0 THEN Put16(adr) END;
      | RidxMd :         IF wid = word THEN ext := RX*LS12 + scl*LS9
                         ELSE ext := RX*LS12 + LS11 + scl*LS9 END;
                         Put16(ext + (adr MOD 256));
      | conMd :          IF typ = stringtyp THEN
                           Put16(val.D0 + (maxP+maxM)*4);
                         ELSE sz := typ^.size;
                           IF    sz = 1 THEN Put16(WordVal(x))
                           ELSIF sz = 2 THEN Put16(WordVal(x))
                           ELSIF sz = 4 THEN Put32(LongVal(x))
                           ELSIF sz = 8 THEN
                             Put16(val.D0); Put16(val.D1);
                             Put16(val.D2); Put16(val.D3);
                           END;
                         END;
      | stkMd :          (* no extension *)
      | AregMd,DregMd :  (* no extension *)
      | procMd :         IF (proc # NIL) & (proc^.pd # NIL) &
                            (proc^.pd^.adr # 0) THEN
                           (* local procedure *)
                           Put16(proc^.pd^.adr - pc);
                         ELSE (* external procedure *)
                           (* no extension *)
                         END;
      | prgMd :          Put16(where - pc);
      | typMd,codMd :    (* no extension *)
      | cocMd,fltMd :    (* no extension *)
      END (*CASE*);
    END (*WITH*);
  END Ext;

  PROCEDURE ReduceIndir(VAR x : Item; ea : INTEGER);
    (* Note : A-Registers internally numbered from 8 .. 15! *)
    VAR src, dst : Register;
  BEGIN
    WITH x DO
      CASE mode OF
        absMd :
          GetReg(dst,Areg);
          Put16(MOVEAL + (dst MOD 8)*LS9 + ea);
          Ext(x);
      | RindMd,RidxMd :
          src := R;
          IF Islocked(src) THEN GetReg(dst,Areg)
          ELSE dst := src END;
          Put16(MOVEAL + (dst MOD 8)*LS9 + ea);
          Ext(x);
          IF dst # src THEN ReleaseReg(src) END;
          IF mode = RidxMd THEN ReleaseReg(RX) END;
      END (*CASE*);
      (* transform all modes to 'RindMd' *)
      mode := RindMd; R := dst; (* R IN { 8..15 } *)
      indir := FALSE; adr := off; off := 0;
    END (*WITH*);
  END ReduceIndir;

  PROCEDURE GeaP(VAR x : Item; VAR fea : INTEGER);
    (* effective address of an item designating a procedure. *)
    VAR An : Register;
  BEGIN
    WITH x DO
      IF (proc # NIL) & (proc^.pd # NIL) &
         (proc^.pd^.adr # 0) THEN (* local procedure *)
        fea := PREL;
      ELSE (* external procedure *)
        GetReg(An,Areg);
        Put16(MOVEAL + (An MOD 8)*LS9 + AOFF + SB);
        Put16((maxP + proc^.pmod)*4);
        Put16(MOVEAL + (An MOD 8)*LS9 + AOFF + (An MOD 8));
        Put16(proc^.pd^.num*4);
        (* transform 'procMd' to 'AregMd' *)
        SetregMd(x, An, typ);
        fea := ADIR + (An MOD 8);
      END;
    END (*WITH*);
  END GeaP;

  PROCEDURE Gea(VAR x : Item; VAR fea : INTEGER);
    (* give effective address of x. *)
    VAR ea : INTEGER; An : Register;
  BEGIN
    WITH x DO
      CASE mode OF
        absMd :             ea := XXXL;
      | RindMd :            IF R = (MP + 8) THEN
                              IF lev # curLev THEN downlevel(x) END;
                            END;
                            IF adr # 0 THEN ea := AOFF + (R MOD 8)
                            ELSE ea := AIDR + (R MOD 8) END;
      | RidxMd :            IF (-128 <= adr) & (adr <= 127) THEN
                              ea := AIDX + (R MOD 8)
                            ELSE (* adr out of 8-bit range *)
                              IF Islocked(R) THEN GetReg(An,Areg)
                              ELSE An := R END;
                              Put16(LEA + (An MOD 8)*LS9 + AIDX + (R MOD 8));
                              IF wid = word THEN Put16(RX*LS12 + scl*LS9)
                              ELSE Put16(RX*LS12 + LS11 + scl*LS9) END;
                              IF R # An THEN ReleaseReg(R) END;
                              ReleaseReg(RX);
                              (* transform 'RidxMd' to 'RindMd' *)
                              mode := RindMd; ea := AOFF + (An MOD 8);
                              R := An;
                            END (*RidxMd*);
      | conMd :             IF typ = stringtyp THEN
                              ea := AOFF + SB (* SB-relative *)
                            ELSE
                              ea := IMM (* for all sizes *)
                            END;
      | stkMd :             ea := AINC + SP;  (* gives (SP)+ *)
      | AregMd :            ea := ADIR + (R MOD 8);
      | DregMd :            ea := DDIR + (R MOD 8);
      | prgMd :             ea := PREL;
      | typMd, codMd :      ea := DDIR + D0; (* dummy effective address *)
                            err(232);        (* NO address equivalent ! *)
      | procMd, cocMd,
        fltMd :             ea := DDIR + D0; (* dummy effective address *)
                            err(233);        (* should never occur here!*)
      END (*CASE*);
      IF (mode < conMd) & indir THEN
        ReduceIndir(x,ea);
        IF adr # 0 THEN ea := AOFF + (R MOD 8)
        ELSE ea := AIDR + (R MOD 8) END;
      END;
    END (*WITH*);
    fea := ea ; (* resulting effective address *)
  END Gea;

  PROCEDURE OvflTrap(signed : BOOLEAN);
    (* overflow-check thru TRAPV for signed arithmetic : *)
  BEGIN
    IF NOT ovflchk THEN RETURN END;
    IF signed THEN Put16(TRAPV) END;
  END OvflTrap;

  PROCEDURE OvflCheck(R : Register; signed : BOOLEAN);
    (* overflow-check for 16*16bit signed multiplication : *)
    VAR Dn : Register;
  BEGIN
    IF NOT ovflchk THEN RETURN END;
    IF signed THEN
      GetReg(Dn,Dreg);                     (* scratch reg. *)
      Put16(MOVEW + Dn*LS9 + R);           (* copy wordpart *)
      Put16(EXTL + Dn);                    (* EXT.L Dn      *)
      Put16(CMP + R*LS9 + long*LS6 + Dn);  (* CMP.L  Dn,R   *)
      Put16(BEQ + 6);                      (* BEQ.S  6      *)
      Put16(ORI + IMM);                    (* ORI.W #VBIT,SR*)
      Put16(VBIT);
      Put16(TRAPV);                        (* TRAPV         *)
      ReleaseReg(Dn);
    END;
  END OvflCheck;

  PROCEDURE StackTop(i : INTEGER);
    (* increment/decrement stack pointer SP :  *)
    (*   i > 0 :  increment SP, reset stack    *)
    (*   i < 0 :  decrement SP, reserve stack  *)
    VAR neg : BOOLEAN; c : INTEGER;
  BEGIN
    IF i # 0 THEN
      neg := (i < 0);
      IF ODD(i) THEN
        IF neg THEN DEC(i) ELSE INC(i) END;
      END;
      IF (-8 <= i) & (i <= 8) THEN
        c := (ABS(i) MOD 8)*LS9;
        IF neg THEN Put16(DECSP + c)
        ELSE Put16(INCSP + c) END;
      ELSE
        Put16(LEASP);
        Put16(i);
      END;
    END (*i # 0*);
  END StackTop;

  PROCEDURE SetupSL(plev : INTEGER);
    (* push Static Link onto stack. *)
    CONST  offSL = 8;  (* offset of Static Link relative to MP *)
    VAR N, An : Register; n : INTEGER;
  BEGIN
    IF plev # 0 THEN
      IF plev = curLev THEN
        (* level difference = 0 *)
        Put16(PEA + AIDR + MP);             (* PEA     (MP) *)
      ELSIF plev + 1 = curLev THEN
        (* level difference = 1 *)
        Put16(MVEMSP + AOFF + MP);          (* MOVE.L  offSL(MP),-(SP) *)
        Put16(offSL);
      ELSE
        (* level difference >= 2 *)
        GetReg(N,Areg); An := N MOD 8;
        Put16(MOVEAL + An*LS9 + AOFF + MP); (* MOVEA.L offSL(MP),An *)
        Put16(offSL);
        n := curLev - plev;
        WHILE n > 2 DO
          DEC(n);
          Put16(MOVEAL + An*LS9 + AOFF+An); (* MOVEA.L offSL(An),An *)
          Put16(offSL);
        END;
        Put16(MVEMSP + AOFF + An);          (* MOVE.L  offSL(An),-(SP) *)
        Put16(offSL);
        ReleaseReg(N);
      END;
    END (*plev # 0*);
  END SetupSL;

  PROCEDURE InitM2HM;
    VAR k : INTEGER; exp : LONGINT;
  BEGIN
    curLev := 0;
    MoveCode[byte] := MOVEB; MoveCode[word] := MOVEW;
    MoveCode[long] := MOVEL;
    ShiCode [Asl]  := ASL;   ShiCode [Asr]  := ASR;
    ShiCode [Lsl]  := LSL;   ShiCode [Lsr]  := LSR;
    ShiCode [Rol]  := ROL;   ShiCode [Ror]  := ROR;
    exp := 0D; mask[0] := 0D; mask[32] := -1D;
    FOR k := 1 TO 31 DO exp := exp + exp + 1D; mask[k] := exp END;
    IF DynArrDesSize = 6 THEN hightyp := inttyp
    ELSE hightyp := dbltyp END;
    InitRegs;
  END InitM2HM;

  PROCEDURE LoadAdr(VAR x : Item);
    (* ADR(x)   --->>>  pointer/address-register. *)
    VAR ea, am, op : INTEGER; An : Register; newA, loaded : BOOLEAN;
  BEGIN op := LEA;
    WITH x DO
      IF (mode IN ItSet{stkMd,AregMd,DregMd,cocMd,typMd,codMd,fltMd})
      OR ((mode = conMd) & (typ # stringtyp)) THEN
        err(231); (* no effective address possible *)
        Release(x); SetregMd(x, A0+8, undftyp);
      END;
      IF (mode < conMd) & indir & (off=0) THEN op := MOVEAL; indir := FALSE END;
      IF mode = procMd THEN GeaP(x,ea) ELSE Gea(x,ea) END;
      am := (ea DIV 8)*8;
      newA := TRUE; loaded := FALSE;
      IF mode IN ItSet{RindMd,RidxMd,AregMd} THEN
        IF NOT Islocked(R) THEN newA := FALSE END;
      END;
      IF newA THEN GetReg(An,Areg)
      ELSE An := R;
        IF (am = ADIR) OR ((am = AIDR) & (op = LEA)) THEN loaded := TRUE END;
      END;
      IF NOT loaded THEN
        Put16(op + (An MOD 8)*LS9 + ea);
        Ext(x);
      END;
      IF mode IN ItSet{RindMd,RidxMd,AregMd} THEN
        IF newA THEN ReleaseReg(R) END;
      END;
      IF mode = RidxMd THEN ReleaseReg(RX) END;
      (* resulting mode is 'AregMd'. *)
      SetregMd(x, An, typ);
    END (*WITH*);
  END LoadAdr;

  PROCEDURE Move(VAR x, y : Item);
    (*                                                  *)
    (*    move simple type x  --->>>  simple type y     *)
    (* simple type means : item of size byte/word/long. *)
    (*                                                  *)
    VAR op, ea1, ea2 : INTEGER; lv : LONGINT;
        cload, domove : BOOLEAN; szx, szy : WidType;
  BEGIN
    IF x.mode = cocMd THEN LoadCC(x) END;
    Isz(y,szy); Isz(x,szx);
    Gea(x,ea1); Gea(y,ea2);
    cload := (x.mode = conMd); domove := TRUE;
    IF cload THEN lv := LongVal(x) END;
    IF y.mode = DregMd THEN
      (* load to D-Register : *)
      ea2 := (y.R MOD 8)*LS9;
      IF cload THEN
        (* constant load to D-Register : *)
        IF (lv >= -128D) & (lv <= 127D) THEN
          Put16(MOVEQ + ea2 + (WordVal(x) MOD 256));
        ELSIF (szx <= word) THEN
          Put16(MOVEW + ea2 + IMM);
          Put16(WordVal(x));
        ELSE
          Put16(MOVEL + ea2 + IMM);
          Put32(lv);
        END;
      ELSE
        (* variable load to D-Register : *)
        IF x.mode = DregMd THEN domove := (x.R # y.R) END;
        IF (x.mode = AregMd) & (szy < long) THEN szy := long END;
        op := MoveCode[szy];
        IF domove THEN
          Put16(op + ea2 + ea1);
          Ext(x); (* source effective address extension *)
        END;
      END;
      y.wid := szy;
    ELSIF y.mode = AregMd THEN
      (* load to A-Register : always sign extends the data. *)
      ea2 := (y.R MOD 8)*LS9;
      IF cload THEN
        (* constant load to A-Register : always load long. *)
        IF (lv >= -32768D) & (lv <= 32767D) THEN
          Put16(MOVEAW + ea2 + IMM);
          Put16(WordVal(x));
        ELSE
          Put16(MOVEAL + ea2 + IMM);
          Put32(lv);
        END;
      ELSE
        (* variable load to A-Register : *)
        IF x.mode = AregMd THEN domove := (x.R # y.R) END;
        IF x.mode = DregMd THEN szy := x.wid END;
        IF szy = byte THEN err(293) END;
        op := MoveCode[szy] + ADIR*LS3;
        IF domove THEN
          Put16(op + ea2 + ea1);
          Ext(x); (* source extension *)
        END;
      END;
    ELSE
      (* move to memory : *)
      IF (x.mode = AregMd) & (szy < long) THEN err(292) END;
      IF (y.mode = stkMd) THEN
        (* destination on top of stack : gives -(SP). *)
        ea2 := ADEC + SP;
        SetstkMd(y, y.typ);
      END;
      IF cload & (lv = 0D) THEN
        Put16(CLR + szy*LS6 + ea2);
        Ext(y);  (* extend destination *)
      ELSIF (x.mode # stkMd) OR (y.mode # stkMd) THEN
        op := MoveCode[szy] + Iea(ea2)*LS6 + ea1;
        Put16(op);
        Ext(x);  (* extend source *)
        Ext(y);  (* extend destination *)
      END;
    END;
  END Move;

  PROCEDURE LoadD(VAR x : Item);
    (* load simple type x to a D-Register. *)
    VAR y : Item; Dn : Register;
  BEGIN
    WITH x DO
      IF mode < DregMd THEN
        GetReg(Dn,Dreg);
        SetregMd(y, Dn, typ);
        Move(x,y);
        Release(x);
        x := y;
      ELSIF mode = cocMd THEN LoadCC(x)
      ELSIF mode > DregMd THEN
        err(230); Release(x);
        SetregMd(x, D0, typ);
      END;
    END (*WITH*);
  END LoadD;

  PROCEDURE CheckPointer(VAR x : Item);
    (* check x to be a non-NIL pointer *)
  BEGIN
    IF NOT(rngchk) OR (x.typ = addrtyp) THEN RETURN END;
    LoadD(x);
    Put16(BNE + 12); (* if NOT NIL-pointer *)
    GenHalt(5);
  END CheckPointer;

  PROCEDURE LoadP(VAR x : Item);
    (* load simple type or pointer to an address-register. *)
    VAR y : Item; An : Register;
  BEGIN
    WITH x DO
      IF (mode IN ItSet{RindMd,RidxMd}) & NOT(Islocked(R)) THEN
        SetregMd(y, R, typ);
        Move(x,y);
        SetbusyReg(R);  (* do NOT release register R *)
        IF mode = RidxMd THEN ReleaseReg(RX) END;
        x := y;
      ELSIF (mode < AregMd) OR (mode = DregMd) THEN
        GetReg(An,Areg);
        SetregMd(y, An, typ);
        Move(x,y);
        Release(x);
        x := y;
      ELSIF (mode # AregMd) THEN
        err(230); Release(x);
        SetregMd(x, A0+8, typ);
      END;
    END (*WITH*);
  END LoadP;

  PROCEDURE LoadX(VAR x : Item; req : WidType);
    (* load simple type x to a D-Register and    *)
    (* sign extend it to the width given by req. *)

    VAR y : Item; Dn : Register; sz : WidType;
        cload, signar : BOOLEAN; lv : LONGINT;

    PROCEDURE NewLoadX(VAR old, new : Item);
    BEGIN
      GetReg(Dn,Dreg);
      SetregMd(new, Dn, old.typ);
      IF NOT(signar) & (sz < req) & (sz < long) THEN
        Put16(MOVEQ + Dn*LS9);
      END;
      Move(old,new);
      Release(old);
      IF signar & (sz < req) & (sz < long) THEN
        IF req = word THEN Put16(EXTW + Dn)
        ELSIF sz = byte THEN Put16(EXTBL + Dn)
        ELSE (* sz = word *) Put16(EXTL + Dn)
        END;
      END;
      new.wid := req;
    END NewLoadX;

  BEGIN (* LoadX *)
    IF x.mode = cocMd THEN LoadCC(x) END;
    Isz(x,sz);
    cload := SimpleC(x); (* Real constants not included *)
    signar := SignedT(x);
    WITH x DO
      IF cload THEN
        (* constants always loaded to long width. *)
        lv := LongVal(x);
        GetReg(Dn,Dreg); SetregMd(y, Dn, typ);
        IF (lv >= -128D) & (lv <= 127D) THEN
          Put16(MOVEQ + Dn*LS9 + (WordVal(x) MOD 256));
        ELSE (* not quick *)
          Put16(MOVEL + Dn*LS9 + IMM);
          Put32(lv);
        END;
        y.wid := req; (* long satisfies req anyway *)
        x := y;
      ELSIF (mode = DregMd) THEN
        (* x is already in a D-Register. *)
        IF wid < req THEN
          IF req = word THEN
            IF sz = byte THEN
              IF signar THEN Put16(EXTW + R)
              ELSE (* unsigned types *)
                Put16(ANDI + word*LS6 + R);
                Put16(377B);
              END;
            END;
          ELSIF req = long THEN
            IF signar THEN
              IF sz < long THEN
                IF sz = byte THEN Put16(EXTBL + R)
                ELSE Put16(EXTL + R) END;
              END;
            ELSE (* unsigned types *)
              IF sz < long THEN
                Put16(ANDI + long*LS6 + R);
                IF sz = byte THEN Put32(255D) ELSE Put32(65535D) END;
              END;
            END;
          END;
        END (*wid < req*);
        wid := req;
      ELSIF (mode <= AregMd) THEN
        (* Real constants fall into this variant. *)
        NewLoadX(x,y);
        x := y;
      ELSE
        err(230); Release(x);
        SetregMd(x, D0, typ);
      END;
    END (*WITH*);
  END LoadX;

  PROCEDURE MoveAdr(VAR x, y : Item);
    (*   ADR(x)   --->>>  y      *)
    VAR op, src, dst : INTEGER; o, s : StrPtr;
  BEGIN
    WITH x DO
      o := typ;   (* save original type of x *)
      s := y.typ; (* save original type of y *)
      IF (mode IN ItSet{stkMd,AregMd,DregMd,cocMd,typMd,codMd,fltMd})
      OR ((mode = conMd) & (typ # stringtyp)) THEN
        err(231); (* no effective address possible *)
        Release(x); SetregMd(x, A0+8, undftyp);
      END;
      IF y.mode = stkMd THEN (* push address of x *)
        op := 0;
        IF (mode < conMd) & indir & (off = 0) THEN
          indir := FALSE; op := MVEMSP;
        END;
        IF mode = procMd THEN GeaP(x,src) ELSE Gea(x,src) END;
        IF mode = AregMd THEN
          op := MVEMSP;   (* MOVE.L An,-(SP) *)
        ELSIF op = 0 THEN
          op := PEA;
        END;
        Put16(op + src);
        Ext(x);
      ELSE (* move address of x *)
        IF (mode < conMd) & indir & (off = 0) THEN
          indir := FALSE;
        ELSE
          LoadAdr(x);
        END;
        typ := addrtyp; y.typ := addrtyp;
        Move(x,y);
        IF y.mode = DregMd THEN y.wid := long END;
      END;
      typ := o;    (* restore original type of x *)
      y.typ := s;  (* restore original type of y *)
    END (*WITH*);
    Release(x);  (* release associated registers *)
  END MoveAdr;

  PROCEDURE MoveBlock(VAR x, y : Item; sz : INTEGER; isstring : BOOLEAN);
    (*  Move a block of 'sz' bytes from x to y.  *)
    (*                                           *)
    (*  x.mode = stkMd :  block comes from stack *)
    (*  y.mode = stkMd :  block goes onto stack  *)
    (*                                           *)
    (* Dogma : the implementation below presumes *)
    (* -----   that all arrays and records are   *)
    (*         allocated on a Word-boundary.     *)
    (*                                           *)
    VAR hsz, op, src, dst : INTEGER; z : Item; xmode : ItemMode;
  BEGIN
    IF (x.mode # stkMd) OR (y.mode # stkMd) THEN
      xmode := x.mode; (* save original mode of source op. *)
      IF y.mode = stkMd THEN
        StackTop( - sz );
        y.mode := RindMd; (* transform 'stkMd' to 'RindMd' *)
      END;
      IF x.mode = stkMd THEN
        x.mode := RindMd; (* transform 'stkMd' to 'RindMd' *)
      END;
      LoadAdr(x); src := AINC + (x.R MOD 8);
      LoadAdr(y); dst := AINC + (y.R MOD 8);
      op := MOVEB; hsz := ABS(sz);
      IF NOT isstring THEN
        (* Note : always byte - move for Strings due to DBEQ! *)
        IF    (hsz MOD 4) = 0 THEN op := MOVEL; hsz := hsz DIV 4
        ELSIF (hsz MOD 2) = 0 THEN op := MOVEW; hsz := hsz DIV 2
        END;
      END;
      op := op + Iea(dst)*LS6 + src;
      IF    hsz = 1 THEN Put16(op)
      ELSIF hsz = 2 THEN Put16(op); Put16(op)
      ELSIF hsz = 3 THEN Put16(op); Put16(op); Put16(op)
      ELSIF hsz > 0 THEN
        SetconMd(z, hsz - 1, inttyp);
        LoadD(z);
        Put16(op);
        IF isstring THEN Put16(DBEQ + z.R)
        ELSE Put16(DBRA + z.R) END;
        Put16(177774B);
        ReleaseReg(z.R);
      END;
      IF xmode = stkMd THEN StackTop( sz ) END;
    END;
  END MoveBlock;

  PROCEDURE ConvertTyp(functyp : StrPtr; VAR x : Item);
    VAR fs, xs : INTEGER; szf, szx : WidType; y : Item;
  BEGIN
    SetregMd(y, D0, functyp);  (* dummy for SimpleT *)
    WITH x DO
      fs := functyp^.size;
      xs := typ^.size;
      IF fs # xs THEN
        IF SimpleT(x) & SimpleT(y) THEN
          Isz(x,szx); Isz(y,szf);
          IF mode = conMd THEN
            SetconMd(x, LongVal(x), functyp);
          ELSIF (mode <= DregMd) OR (mode = cocMd) THEN
            IF szf <= szx THEN LoadD(x)
            ELSE LoadX(x,szf) END;
          ELSE err(81); Release(x);
          END;
        ELSE err(81); Release(x);
        END;
      END;
      typ := functyp; (* type of x IS changed ! *)
      IF (mode = DregMd) & SimpleT(y) THEN Isz(y,wid) END;
    END (*WITH*);
  END ConvertTyp;

  PROCEDURE CallSystem(sysp : INTEGER);
    (* call System.#sysp where sysp = ordinal of procedure.  *)
  BEGIN
    ExternalCall(maxM - 1, sysp);
  END CallSystem;

  PROCEDURE GenHalt(haltindex : INTEGER);
  BEGIN
    haltindex := haltindex MOD 256;
    IF (haltindex # 0) & NOT(rngchk) THEN RETURN END;
    Put16(MOVEQ + D0*LS9 + haltindex);
    CallSystem(HALTX);
  END GenHalt;

  PROCEDURE Op1(op : INTEGER; VAR x : Item);
    (* generate instructions with 1 operand represented   *)
    (* by an eff. address in bits [0..5] and its variable *)
    (* size in bits [6..7] of the instruction word.       *)
    (* Used for CLR, TST, NEG, COM (=NOT), INC1, DEC1.    *)
    (* Not used for JSR, JMP, PEA, Scc because these      *)
    (* instructions have a fixed size.                    *)
    (* Note : x can be a memory location or on TOS.       *)
    VAR ea : INTEGER; sz : WidType;
  BEGIN
    Isz(x,sz);
    Gea(x,ea);
    WITH x DO
      IF mode = stkMd THEN
        (* change (SP)+ to (SP). *)
        (* for TST the operand is popped from stack! *)
        IF op # TST THEN ea := AIDR + SP END;
      END;
      Put16(op + sz*LS6 + ea);
      Ext(x);
      IF mode = DregMd THEN wid := sz END;
    END (*WITH*);
  END Op1;

  PROCEDURE Power2(VAR x : Item; VAR exp2 : INTEGER) : BOOLEAN;
    (* Note : negative numbers must NOT return as power of 2. *)
    VAR pw2 : BOOLEAN;
        v   : LONGINT;
  BEGIN
    exp2 := 0; pw2 := FALSE;
    IF SimpleC(x) THEN
      v := LongVal(x);
      pw2 := (v >= 1D);              (* 1 = 2**0 *)
      WHILE (v > 1D) & pw2 DO
        pw2 := NOT ODD(v);
        v := LSH(v, -1);             (* v := v DIV 2 *)
        INC(exp2);                   (* side effect of Power2 *)
      END;
    END;
    RETURN pw2                       (* 0 <= exp2 <= 31 *)
  END Power2;

  PROCEDURE MulPw2(VAR x : Item; exp : INTEGER; ovfl : BOOLEAN);
    (*       x * (power of 2)               *)
    (* relevant is the width, not the size! *)
    VAR op : INTEGER; Dn : Register;
  BEGIN
    IF exp # 0 THEN
      IF SignedT(x) THEN op := ASL ELSE op := LSL END;
      op := op + x.wid*LS6 + x.R;
      IF exp IN {1..8} THEN (* immediate shift *)
        Put16(op + (exp MOD 8)*LS9);
      ELSE (* register by register shift *)
        GetReg(Dn,Dreg);
        Put16(MOVEQ + Dn*LS9 + exp);
        Put16(op + Dn*LS9 + LS5);
        ReleaseReg(Dn);
      END;
      IF ovfl THEN OvflTrap(SignedT(x)) END;
      (* do not change x.wid *)
    END (*exp # 0*);
  END MulPw2;

  PROCEDURE MUL2(VAR x, y : Item; ovfl : BOOLEAN);
    (*  x  *  y  --->>  x  *)
    VAR op, ea, pw2 : INTEGER; szx, szy : WidType;
        signar, loady : BOOLEAN;
  BEGIN
    Isz(x,szx); Isz(y,szy);
    signar := SignedT(x) OR SignedT(y);
    loady  := y.mode IN ItSet{AregMd,stkMd};
    IF szx < long THEN (* szy < long expected *)
      (* 16 * 16 bits *)
      IF (szy = byte) OR loady THEN LoadX(y,word) END;
      LoadX(x,word);  (* assert DregMd for destination *)
      IF Power2(y,pw2) THEN MulPw2(x,pw2,ovfl)
      ELSE
        IF signar THEN op := MULS ELSE op := MULU END;
        Gea(y,ea);
        Put16(op + x.R*LS9 + ea);
        Ext(y);
        x.wid := long;
        IF ovfl THEN OvflCheck(x.R, signar) END;
      END;
    ELSE
      (* 32 * 32 bits *)
      IF (szy < long) OR loady THEN LoadX(y,long) END;
      LoadX(x,long);  (* assert DregMd for destination *)
      IF Power2(y,pw2) THEN MulPw2(x,pw2,ovfl)
      ELSE
        op := x.R*LS12;
        IF signar THEN op := op + LS11 END;
        Gea(y,ea);
        Put16(MULL + ea); Put16(op);
        Ext(y);
        (* x.wid remains long. *)
        IF ovfl THEN OvflTrap(signar) END;
      END;
    END;
    Release(y);
  END MUL2;

  PROCEDURE SHI2(inst : INTEGER; VAR x, y : Item);
    (*  shift left/right x by y.  *)
    VAR op, cv : INTEGER; szx : WidType; lv : LONGINT; imm : BOOLEAN;
  BEGIN
    IF (x.mode = stkMd) & (y.mode = stkMd) THEN LoadD(y) END;
    LoadD(x);
    Isz(x,szx);
    op := inst + szx*LS6 + x.R; (* register to be shifted *)
    imm := FALSE;
    IF SimpleC(y) THEN
      lv := LongVal(y);
      IF (lv >= 1D) & (lv <= 8D) THEN imm := TRUE END;
    END;
    IF imm THEN (* immediate shift : value 0 excluded *)
      cv := SHORT(lv MOD 8);
      Put16(op + cv*LS9);
    ELSE (* register by register shift *)
      LoadD(y);                 (* load shift count *)
      op := op + y.R*LS9 + LS5; (* indicates register shift *)
      (* shift is modulo 64 : no chechs are made for *)
      (* positive or negative values of shift count. *)
      Put16(op);
    END;
    x.wid := szx; (* resulting width of D-Register *)
    Release(y);
  END SHI2;

  PROCEDURE LOG2(inst : INTEGER; VAR x, y : Item);
    (* the logical operators AND, OR, EOR.  *)
    (*      x   AND   y  --->>   x          *)
    (*      x   OR    y  --->>   x          *)
    (*      x   EOR   y  --->>   x          *)
    (* Note : x can be a memory location *)
    (*        or on top of stack.        *)
    VAR op, eax, eay : INTEGER; szx, szy : WidType;
  BEGIN
    Isz(x,szx); Isz(y,szy);
    Gea(x,eax);
    IF x.mode = stkMd THEN eax := AIDR + SP (* gives (SP) *) END;
    IF SimpleC(y) & (x.mode # AregMd) THEN
      (* ANDI / ORI / EORI *)
      IF inst = ANDL THEN op := ANDI
      ELSIF inst = ORL THEN op := ORI
      ELSE op := EORI END;
      Put16(op + szx*LS6 + eax);
      Ext(y); (* source extension first *)
      Ext(x); (* destination extension  *)
    ELSE
      IF (x.mode = stkMd) & (y.mode = stkMd) THEN LoadD(y) END;
      IF x.mode = AregMd THEN LoadD(x); Gea(x,eax) END;
      op := inst + szx*LS6;
      Gea(y,eay);
      IF (x.mode = DregMd) & (inst # EORL) THEN
        (* destination is D-Register : *)
        Put16(op + x.R*LS9 + eay);
        Ext(y); (* source extension *)
      ELSE
        (* destination is memory location or inst = EOR. *)
        (* assert source operand in D-Register.          *)
        LoadD(y);
        IF (inst # EORL) THEN
          op := op + LS8;
        END;
        Put16(op + y.R*LS9 + eax);
        Ext(x); (* destination extension *)
      END;
    END;
    IF x.mode = DregMd THEN x.wid := szx END;
    Release(y);
  END LOG2;

  PROCEDURE DivPw2(VAR x : Item; exp : INTEGER; modulus : BOOLEAN);
    VAR m : LONGINT; y : Item;
  BEGIN
    IF exp = 0 THEN (* DIV/MOD 1 *)
      IF modulus THEN Release(x); SetconMd(x, 0D, x.typ) END;
      (* else no change if x DIV 1 *)
    ELSE
      LoadD(x);
      IF NOT modulus THEN (* DIV *)
        SetconMd(y, exp, inttyp);
        IF SignedT(x) THEN SHI2(ASR,x,y)
        ELSE SHI2(LSR,x,y)
        END;
      ELSE (* MOD *)
        m := mask[exp];  (* 2**exp - 1 *)
        SetconMd(y, m, x.typ);
        LOG2(ANDL,x,y);
      END;
    END;
    (* x.wid is set by SHI2 and LOG2 *)
    Release(y);
  END DivPw2;

  PROCEDURE DIV2(VAR x, y : Item; modulus : BOOLEAN);
    (*  x  DIV/MOD  y  --->>  x  *)
    VAR op, ea, pw2 : INTEGER; szx, szy : WidType;
        signar, loady : BOOLEAN;
  BEGIN
    Isz(x,szx); Isz(y,szy);
    signar := SignedT(x) OR SignedT(y);
    loady  := y.mode IN ItSet{AregMd,stkMd};
    IF szx < long THEN (* szy < long expected *)
      (* 32 DIV/MOD 16 bits *)
      IF (szy = byte) OR loady THEN LoadX(y,word) END;
      IF Power2(y,pw2) THEN DivPw2(x,pw2,modulus)
      ELSE (* extend destination to 32 bits *)
        IF signar THEN op := DIVS ELSE op := DIVU END;
        LoadX(x,long); IF signar & modulus THEN LoadX(y,word) END;
        Gea(y,ea); Put16(op + x.R*LS9 + ea); Ext(y);
        (* quotient in bits 0..15, remainder in bits 16..31 : *)
        IF signar THEN
          IF ~modulus THEN (* Oberon's DIV *)
            Put16(TST + long*LS6 + x.R); Put16(BPL + 2);
            Put16(DEC1 + word*LS6 + x.R);
          ELSE (* Oberon's MOD *)
            Put16(SWAP + x.R); Put16(TST + word*LS6 + x.R); Put16(BPL + 2);
            Put16(ADD + word*LS6 + x.R*LS9 + y.R);
          END;
        ELSE
          IF modulus THEN Put16(SWAP + x.R) END;
        END;
        x.wid := word; (* x.R remains reserved, width is word *)
      END;
    ELSE
      (* 32 DIV/MOD 32 bits *)
      IF (szy < long) OR loady THEN LoadX(y,long) END;
      IF Power2(y,pw2) THEN DivPw2(x,pw2,modulus)
      ELSE
        LoadX(x,long); IF signar & modulus THEN LoadX(y,long) END;
        op := x.R*LS12; (* Dq = x.R, Dr = D0 *)
        IF signar THEN op := op + LS11 END;
        Gea(y,ea); Put16(DIVL + ea); Put16(op); Ext(y);
        (* quotient in x.R, remainder in D0 : *)
        IF signar THEN (* Oberon's DIV and MOD *)
          Put16(TST + long*LS6 + D0); Put16(BPL + 2);
          IF ~modulus THEN Put16(DEC1 + long*LS6 + x.R)
          ELSE Put16(ADD + long*LS6 + D0*LS9 + y.R) END;
        END;
        IF modulus THEN Put16(MOVEL + x.R*LS9) END;
        (* x.R remains reserved, x.wid remains long *)
      END;
    END;
    Release(y);
  END DIV2;

  PROCEDURE ADD2(inst : INTEGER; VAR x, y : Item);
    (*       x  +  y    --->>   x        *)
    (*       x  -  y    --->>   x        *)
    (* Note : x can be a memory location *)
    (*        or on top of stack.        *)
    VAR op, eax, eay : INTEGER; szx, szy : WidType;
        cadd : BOOLEAN; lv : LONGINT;
  BEGIN
    Isz(x,szx); Isz(y,szy);
    Gea(x,eax);
    IF x.mode = stkMd THEN eax := AIDR + SP (* gives (SP) *) END;
    cadd := SimpleC(y);
    IF cadd THEN lv := LongVal(y) END;
    IF cadd & (x.mode # AregMd) THEN
      IF (lv >= 1D) & (lv <= 8D) THEN
        IF inst = ADD THEN op := ADDQ ELSE op := SUBQ END;
        eay := SHORT(lv MOD 8);
        Put16(op + eay*LS9 + szx*LS6 + eax);
        Ext(x);
      ELSIF (lv # 0D) THEN
        IF inst = ADD THEN op := ADDI ELSE op := SUBI END;
        Put16(op + szx*LS6 + eax);
        Ext(y); (* extend source constant first *)
        Ext(x); (* extend destination *)
      END;
    ELSE
      IF inst = ADD THEN op := ADD ELSE op := SUB END;
      IF (x.mode = stkMd) & (y.mode = stkMd) THEN LoadD(y) END;
      Gea(y,eay);
      IF x.mode = DregMd THEN
        (* destination is D-Register : *)
        op := op + (x.R MOD 8)*LS9;
        IF y.mode = AregMd THEN
          (* allow word/long only for source in A-Reg. *)
          IF szy = byte THEN err(288) END;
        END;
        Put16(op + szx*LS6 + eay);
        Ext(y); (* extend source *)
      ELSIF x.mode = AregMd THEN
        (* destination is A-Register : *)
        op := op + (x.R MOD 8)*LS9;
        (* allow long operation only. *)
        IF szx < long THEN err(287) END;
        Put16(op + 700B + eay); (* 700B generates ADDA.L *)
        Ext(y); (* extend source *)
      ELSE
        (* destination is memory location : *)
        (* assert source op. in D-Register. *)
        LoadD(y);
        op := op + y.R*LS9 + LS8;
        Put16(op + szx*LS6 + eax);
        Ext(x); (* extend destination *)
      END;
    END;
    IF x.mode = DregMd THEN x.wid := szx END;
    Release(y);
  END ADD2;

  PROCEDURE Cmp2(VAR x, y : Item);
    (*         x   -   y                 *)
    (* Note : x can be a memory location *)
    (*        or on top of stack.        *)
    VAR op, eax, eay : INTEGER; szx, szy : WidType; lv : LONGINT;
  BEGIN
    Isz(x,szx); Isz(y,szy);
    Gea(x,eax);
    IF SimpleC(y) & NOT(x.mode IN ItSet{AregMd,conMd}) THEN
      (* source is constant : *)
      lv := LongVal(y);
      IF lv = 0D THEN Op1(TST,x)   (* x would be popped if stkMd *)
      ELSE op := CMPI;
        Put16(op + szx*LS6 + eax); (* x would be popped if stkMd *)
        Ext(y); (* immediate source *)
        Ext(x); (* extend destination *)
      END;
    ELSIF x.mode = AregMd THEN
      (* destination is A-Register : *)
      Gea(y,eay); op := CMP + (x.R MOD 8)*LS9;
      (* allow long operation only. *)
      IF szx < long THEN err(287) END;
      Put16(op + 700B + eay); (* 700B generates CMPA.L *)
      Ext(y); (* extend source *)
    ELSE
      (* destination must be D-Register : *)
      IF (x.mode = stkMd) & (y.mode = stkMd) THEN LoadD(y) END;
      LoadD(x);
      Gea(y,eay); op := CMP + (x.R MOD 8)*LS9;
      IF y.mode = AregMd THEN
        (* allow word/long only for source in A-Reg. *)
        IF szy = byte THEN err(288) END;
      END;
      Put16(op + szx*LS6 + eay);   (* y would be popped if stkMd *)
      Ext(y); (* extend source *)
    END;
    Release(y);
    (* result is in the condition code register! *)
  END Cmp2;

  PROCEDURE In2(VAR x, y : Item);
    (* perform bit-manipulations : BTST.  *)
    (* y is the destination bit pattern,  *)
    (* x is the bit number.               *)

    (*   Caution : NEVER execute a BTST-instruction if     *)
    (*   the bit number is greather than the width of the  *)
    (*   set, because hardware takes count modulo 32.      *)

    VAR op : INTEGER;
        v, min, max : INTEGER;
        sz : WidType;
        Dn : Register;
  BEGIN
    (* width of set defines allowed bit-numbers *)
    Isz(y,sz); min := 0;
    max := LSH(8, sz) - 1;
    IF SimpleC(x) & NOT SimpleC(y) THEN
      (* static bit : *)
      v := WordVal(x);
      IF (v < min) OR (v > max) THEN
        (* inhibit BTST :   *)
        (* force Z-Bit = 1. *)
        GetReg(Dn,Dreg);
        Put16(MOVEQ + Dn*LS9);
        ReleaseReg(Dn);
      ELSE
        LoadD(y); (* load bit pattern *)
        op := BTST + LS11 - LS8 + y.R;
        Put16(op);
        Put16(v);
      END;
    ELSE
      (* dynamic bit : *)
      LoadD(y);                          (* load bit pattern    *)
      LoadD(x);                          (* load bit number     *)
      op := BTST + x.R*LS9 + y.R;
      Put16(CMPI + x.wid*LS6 + x.R);     (* CMPI    #maxi,bitnr *)
      IF x.wid = long THEN               (* inhibit BTST if     *)
        Put32(max)                       (* bitnr out of width  *)
      ELSE                               (* of the set          *)
        Put16(max)
      END;
      Put16(BLS + 4);                    (* if bitnr in range   *)
      Put16(MOVEQ + x.R*LS9);            (* force Z-Bit = 1     *)
      Put16(BRA + 2);                    (* skip bitop-instr.   *)
      Put16(op);                         (* dynamic bitop       *)
    END;
    Release(y);
    (* result is in the condition code register! *)
  END In2;

  PROCEDURE Neg1(VAR x : Item);
  BEGIN
    LoadD(x);
    Op1(NEG,x);
    OvflTrap(SignedT(x));
  END Neg1;

  PROCEDURE Abs1(VAR x : Item);
  BEGIN
    LoadD(x);
    Op1(TST,x);
    Put16(BGE + 2);
    Op1(NEG,x); (* gives exactly one 16-bit instruction *)
    OvflTrap(SignedT(x));
  END Abs1;

  PROCEDURE Cap1(VAR x : Item);
  BEGIN
    LoadD(x);
    Put16(CMPI + byte*LS6 + x.R); Put16(97);
    Put16(BCS + 10);
    Put16(CMPI + byte*LS6 + x.R); Put16(122);
    Put16(BHI + 4);
    Put16(ANDI + byte*LS6 + x.R); Put16(95);
  END Cap1;

  PROCEDURE Tst1(VAR x : Item);
  BEGIN
    IF x.mode IN ItSet{conMd,AregMd} THEN LoadD(x) END;
    Op1(TST,x);
  END Tst1;

  PROCEDURE Com1(VAR x : Item);
  BEGIN
    LoadD(x);
    Op1(COM,x);
  END Com1;

  PROCEDURE Inc1(VAR x : Item);
  BEGIN
    Op1(INC1,x);
    OvflTrap(SignedT(x));
  END Inc1;

  PROCEDURE Dec1(VAR x : Item);
  BEGIN
    Op1(DEC1,x);
    OvflTrap(SignedT(x));
  END Dec1;

  PROCEDURE Add2(VAR x, y : Item);
    VAR op : INTEGER; lv : LONGINT;
  BEGIN op := ADD;
    IF y.mode = conMd THEN lv := LongVal(y);
      IF lv < 0D THEN SetconMd(y, -lv, y.typ); op := SUB END;
    END;
    ADD2(op,x,y);
    IF x.mode # AregMd THEN OvflTrap(SignedT(x)) END;
  END Add2;

  PROCEDURE Sub2(VAR x, y : Item);
    VAR op : INTEGER; lv : LONGINT;
  BEGIN op := SUB;
    IF y.mode = conMd THEN lv := LongVal(y);
      IF lv < 0D THEN SetconMd(y, -lv, y.typ); op := ADD END;
    END;
    ADD2(op,x,y);
    IF x.mode # AregMd THEN OvflTrap(SignedT(x)) END;
  END Sub2;

  PROCEDURE And2(VAR x, y : Item);
  BEGIN
    LOG2(ANDL,x,y);
  END And2;

  PROCEDURE Or2(VAR x, y : Item);
  BEGIN
    LOG2(ORL,x,y);
  END Or2;

  PROCEDURE Eor2(VAR x, y : Item);
  BEGIN
    LOG2(EORL,x,y);
  END Eor2;

  PROCEDURE Div2(VAR x, y : Item);
  BEGIN
    IF (y.mode = conMd) & (LongVal(y) = 0D) THEN err(205)
    ELSE DIV2(x,y, FALSE)
    END;
  END Div2;

  PROCEDURE Mod2(VAR x, y : Item);
  BEGIN
    IF (y.mode = conMd) & (LongVal(y) = 0D) THEN err(205)
    ELSE DIV2(x,y, TRUE)
    END;
  END Mod2;

  PROCEDURE Mul2(VAR x, y : Item);
  BEGIN
    IF ((y.mode = conMd) & (LongVal(y) = 0D)) THEN
      Release(x); SetconMd(x, 0D, x.typ)
    ELSIF NOT((y.mode = conMd) & (LongVal(y) = 1D)) THEN
      MUL2(x,y,TRUE)
    END;
  END Mul2;

  PROCEDURE Shi2(VAR x, y : Item; shiftop : ShiType);
  BEGIN
    SHI2( ShiCode[shiftop], x, y);
  END Shi2;

  PROCEDURE Ash2(VAR x, y : Item; shiftop : ShiType);
    (*                                         *)
    (*     Arithmetic Shift                    *)
    (*     Logical Shift        x by y.        *)
    (*     Rotate Shift                        *)
    (*                                         *)
    (*  y is the shift count of type INTEGER   *)
    (*  or INTEGER.                           *)
    (*  if y >= 0 then shift LEFT.             *)
    (*  if y <  0 then shift RIGHT.            *)
    (*                                         *)
    VAR op, ct, rm : INTEGER; sz : WidType;
  BEGIN
    Isz(x,sz);
    op := ShiCode[shiftop] + sz*LS6 + (x.R MOD 8); (* initially LEFT shift *)
    IF y.mode = conMd THEN
      (* immediate shift count : bit 5 remains 0! *)
      ct := WordVal(y);
      IF ct < 0 THEN
        op := op - LS8; (* RIGHT shift *)
        (* Note : overflow-checks must be OFF for compiler! *)
        ct := ABS(ct);
      END;
      ct := ct MOD 32; (* shift count modulo 32 *)
      rm := ct MOD 8; ct := LSH(ct, -3);
      IF rm # 0 THEN Put16(op + rm*LS9) END;
      WHILE ct > 0 DO Put16(op); DEC(ct) END;
    ELSE
      (* variable shift count of type INTEGER/CARDINAL : *)
      (* INTEGER/CARDINAL count treated the same way.    *)
      (* Note : Hardware takes shift count modulo 64 !   *)
      LoadX(y,word);                     (* load shift count  *)
      op := op + y.R*LS9 + LS5;          (* register shift    *)
      Put16(TST + word*LS6 + y.R);       (* test shift count  *)
      Put16(BPL + 6);                    (* if count >= 0     *)
      Put16(NEG + word*LS6 + y.R);       (* abs. value count  *)
      Put16(op - LS8);                   (* RIGHT shift       *)
      Put16(BRA + 2);                    (* skip next instr.  *)
      Put16(op);                         (* LEFT shift        *)
    END;
    x.wid := sz; (* resulting width of D-Register *)
    Release(y);
  END Ash2;

  PROCEDURE ConIndex(VAR x : Item; inc : INTEGER);
    (* called for constant index and field-offset. *)
    (*   if NOT indir :  adr-field is incremented  *)
    (*   if indir     :  off-field is incremented. *)
    VAR i : INTEGER;
  BEGIN
    WITH x DO
      IF mode < conMd THEN
        (* reference to indir, adr, off allowed. *)
        IF NOT indir THEN i := adr ELSE i := off END;
        IF (i >= 0) & (inc <= MaxInt - i)
        OR (i <  0) & (inc >= MinInt - i) THEN
          i := i + inc;
          IF NOT indir THEN adr := i ELSE off := i END;
        ELSE (* offset overflow *)
          LoadAdr(x); mode := RindMd; (* transform 'AregMd' to 'RindMd' *)
          adr := inc;
        END;
      ELSE (* all other modes *)
        err(235);
      END;
    END (*WITH*);
  END ConIndex;

  PROCEDURE Normalize(VAR x : Item; i : INTEGER);
    (* normalize x with the low-bound i *)
    VAR op : INTEGER; y : Item;
  BEGIN
    IF i # 0 THEN
      (* Note : overflow-checks must be OFF for compiler! *)
      IF i > 0 THEN op := SUB ELSE op := ADD; i := ABS(i) END;
      SetconMd(y, i, x.typ);
      ADD2(op,x,y);
    END;
  END Normalize;

  PROCEDURE CheckHigh(VAR x, high : Item);
    (* check item associated with x to be in the   *)
    (* range indicated by [ 0.. (high) ].          *)
    (* Note : CHK treats operand and upper-bound   *)
    (*        as signed 2's complement integers!   *)
    VAR ea, op : INTEGER; sz, hsz : WidType;
  BEGIN
    IF NOT rngchk THEN RETURN END;
    LoadD(x); (* assert x to be loaded into a D-register *)
    Isz(high,hsz); Isz(x,sz);
    IF hsz # sz THEN LoadX(high,sz) END;
    Gea(high,ea);
    IF sz = word THEN op := CHK ELSE op := CHKL END;
    Put16(op + x.R*LS9 + ea);
    Ext(high);
    Release(high);
  END CheckHigh;

  PROCEDURE CheckClimit(VAR x : Item; limit : LONGINT);
    (* check item associated with x to be in the   *)
    (* range indicated by [ 0 .. limit ].          *)
    (* Note : Trap taken always if limit < 0.      *)
    (*        CHK treats operand and upper-bound   *)
    (*        as signed 2's complement integers!   *)
    VAR sz : WidType;
  BEGIN
    IF NOT rngchk THEN RETURN END;
    IF (limit < 0D) THEN err(286) END; (* invalid limit *)
    LoadD(x); (* assert x to be loaded into a D-register *)
    Isz(x,sz);
    IF sz = word THEN (* CHK *)
      Put16(CHK + x.R*LS9 + IMM);
      Put16(VAL(INTEGER, limit));
    ELSE (* CHKL *)
      Put16(CHKL + x.R*LS9 + IMM);
      Put32(limit);
    END;
  END CheckClimit;

  PROCEDURE CheckRange(VAR x: Item; min, max, BndAdr: INTEGER);
    (* check x in the constant range [ min .. max ]. *)
    VAR htyp : StrPtr; sz : WidType;
  BEGIN
    IF NOT rngchk THEN RETURN END;
    IF SimpleT(x) THEN Isz(x,sz);
      htyp := x.typ; (* hold original type of x *)
      LoadX(x,word);
      IF sz <= word THEN x.typ := inttyp END;
      Normalize(x, min);
      IF (max >= min) & ((min >= 0) OR (max <= (MaxInt + min))) THEN
        max := max - min
      ELSE
        err(286); max := 0; (* range distance too big *)
      END;
      CheckClimit(x, max);
      (* Note : overflow-checks must be OFF for compiler! *)
      (* recover original value of x : *)
      Normalize(x, - min);
      x.typ := htyp; (* recover type of x *)
    END;
  END CheckRange;

  PROCEDURE CheckDbltoSingle(VAR x, y : Item);
    (* range check for assignment of double-word type x *)
    (* to single-word type y (INTEGER/CARDINAL).        *)
    VAR Dn : Register;
  BEGIN
    IF NOT rngchk THEN RETURN END;
    LoadD(x);                             (* load long x *)
    GetReg(Dn,Dreg);                      (* scratch reg. *)
    IF NOT SignedT(y) THEN
       Put16(MOVEQ + Dn*LS9);             (* MOVEQ #0,Dn *)
    END;
    Put16(MOVEW + Dn*LS9 + x.R);          (* copy word part *)
    IF SignedT(y) THEN
      IF NOT SignedT(x) THEN              (* Unsigned to Signed *)
        Put16(BMI + 6);                   (* exclude values < 0 *)
      END;
      Put16(EXTL + Dn);                   (* EXT.L Dn    *)
    END;
    Put16(CMP + x.R*LS9 + long*LS6 + Dn); (* CMP.L  Dn,x.R *)
    Put16(BEQ + 4);                       (* BEQ.S  4      *)
    Put16(CHK + Dn*LS9 + IMM);            (* CHK    #-1,Dn *)
    Put16(-1); (* trap always *)
    ReleaseReg(Dn);
  END CheckDbltoSingle;

  PROCEDURE VarIndex(VAR x, y : Item; elsize : INTEGER);
    (* generate x with a variable index y and elementsize elsize. *)
    CONST quad = 3;
    VAR elsz : Item; scale, pw2 : INTEGER;
  BEGIN
    SetconMd(elsz, elsize, y.typ);
    IF elsize = 1 THEN scale := byte
    ELSIF elsize = 2 THEN scale := word
    ELSIF elsize = 4 THEN scale := long
    ELSIF elsize = 8 THEN scale := quad
    ELSE
      IF ~Power2(elsz,pw2) & (y.typ = dbltyp) THEN
        y.typ := inttyp; (* force 16*16Bit MULS.W *)
        SetconMd(elsz, elsize, y.typ);
      END;
      MUL2(y,elsz,FALSE); (* inhibit overflow-checks *)
      scale := byte;
    END;
    LoadAdr(x);
    WITH x DO
      (* transform 'AregMd' to 'RidxMd' *)
      mode := RidxMd;  indir := FALSE;
      adr  := 0;       off   := 0;
      RX   := y.R;     wid   := y.wid;
      scl  := scale;
    END (*WITH*);
  END VarIndex;

  PROCEDURE GetHigh(VAR x : Item);
    (* get high-index of dynamic array parameter : *)
    (*                                             *)
    (* Caution :  x.typ IS changed !               *)
    (* -------                                     *)
  BEGIN
    WITH x DO
      IF mode < conMd THEN
        (* reference to indir, adr, off allowed. *)
        indir := FALSE;    off := 0;
        adr   := adr + 4;  typ := hightyp;
      ELSE err(240)
      END;
    END (*WITH*);
  END GetHigh;

  PROCEDURE PreLoad(VAR op : Symbol; VAR x , y : Item);
    (* preload x and/or y for GenOp.     *)
    (* Note : No exchange of operands    *)
    (* ----   for real types on purpose! *)
    VAR z : Item;
  BEGIN (* do nothing if x is not 'loadable' *)
    IF NOT(SimpleT(x) & SimpleT(y)) THEN RETURN END;
    IF (op = times) OR (op = plus) THEN
      (* symmetric operators : *)
      IF x.mode # DregMd THEN
        IF (y.mode = DregMd) & (y.R IN Rpool) THEN
          z := x; x := y; y := z;
        ELSE
          IF (x.mode = conMd) & (y.mode <= stkMd) THEN
            z := x; x := y; y := z;
          END;
          LoadD(x);
        END;
      (* else x already loaded *)
      END;
    ELSIF (op = div) OR (op = mod) THEN
      (* a-symmetric operators : *)
      (* 32bits / 16bits for DIVS/DIVU ! *)
      LoadD(x);
    ELSIF (op = slash) OR (op = minus) OR (op = rem) THEN
      (* a-symmetric operators : *)
      LoadD(x);
    ELSIF (op >= eql) & (op <= geq) THEN
      (* relational operators : *)
      IF x.mode = conMd THEN
        (* y.mode # conMd ! *)
        z := x; x := y; y := z;
        IF    op = lss THEN op := gtr
        ELSIF op = leq THEN op := geq
        ELSIF op = gtr THEN op := lss
        ELSIF op = geq THEN op := leq
        ELSE (* op := op *)
        END;
      END;
    ELSE (* nothing for all other ops *)
    END;
  END PreLoad;

  PROCEDURE DynArray  (VAR x, y : Item);
    (* generate descriptor for dynamic array parameters : *)
    (*                                                    *)
    (* Caution :    guarantee HIGH to be in the range     *)
    (* -------      0   <=   HIGH   <=   MaxInt.          *)
    (*                                                    *)
    CONST ByteSize = 1;
    VAR high, onstack, e : Item; s : StrPtr;
        i, elsize : INTEGER; dynbyte   : BOOLEAN;
  BEGIN
    dynbyte := (x.typ^.ElemTyp = bytetyp);
    IF (y.typ^.form = Array) THEN
      elsize := y.typ^.ElemTyp^.size;
      IF y.typ^.dyn THEN (* copy existing descriptor *)
        high := y; GetHigh(high);
        IF dynbyte & (elsize # ByteSize) THEN
          LoadD(high);
          Inc1(high);         (* enable overflow-check *)
          SetconMd(e, elsize, high.typ);
          MUL2(high,e,TRUE);
          Op1(DEC1,high);     (* disable overflow-check *)
          IF ovflchk THEN CheckClimit(high, MaxInt - 1) END;
        END;
      ELSE (* generate new descriptor *)
        IF NOT dynbyte THEN
          s := y.typ^.IndexTyp; i := 0;
          WITH s^ DO
            IF form = Range THEN
              IF (max >= min) & ((min >= 0) OR (max <= (MaxInt + min))) THEN
                i := max - min
              ELSE
                err(286); (* range distance too big *)
              END;
            END (*Range*);
          END (*WITH*);
        ELSE
          WITH y.typ^ DO
            IF (form = Array) & (IndexTyp^.form = Range) & (elsize = 1) THEN
              i := IndexTyp^.max - IndexTyp^.min;
            ELSE
              i := size; IF i > 0 THEN DEC(i) END;
            END;
          END;
        END;
        SetconMd(high, i, hightyp);
      END;
    ELSIF (y.typ^.form = String) THEN
      i := y.val.D1; IF i > 0 THEN DEC(i) END;
      SetconMd(high, i, hightyp);
    ELSE
      i := y.typ^.size; IF i > 0 THEN DEC(i) END;
      SetconMd(high, i, hightyp);
      IF y.mode >= conMd THEN err(231) END;
    END;
    SetstkMd(onstack, hightyp);
    Move(high,onstack);
    MoveAdr(y,onstack);
    Release(high);
    Release(y);
  END DynArray;

  PROCEDURE CopyDynArray(a, s : INTEGER);
    (* descriptor at a(MP), element-size is s :  *)
    (* copy (high+1)*s Bytes from [a(MP)] on top *)
    (* of stack and update descriptor address.   *)
    VAR Dn, An, Am : Register; op, src, dst : INTEGER; x, e : Item;
  BEGIN
    SetlocMd(x, a+4, hightyp);
    LoadD(x); Dn := x.R;
    (* Caution : value of HIGH must be in positive INTEGER range, *)
    (* -------   even if HIGH is hold in a longword (LONGINT) !   *)
    (*           this is essential for the code generation below. *)
    Inc1(x);         (* (high + 1)     = nr. of elements *)
    IF (s > 1) THEN  (* (high + 1) * s = nr. of bytes to copy *)
      SetconMd(e, s, x.typ);
      MUL2(x,e,TRUE);
    END;
    IF ovflchk THEN CheckClimit(x, MaxInt - 1) END;
    IF ODD(s) THEN
      (* Note : Dn will never overflow at the INC below ! *)
      Put16(BTST + LS11 - LS8 + Dn);          (* total nr. of bytes   *)
      Put16(0);                               (* must be even         *)
      Put16(BEQ + 2);                         (* skip if already even *)
      Put16(INC1 + word*LS6 + Dn);            (* if odd then + 1      *)
    END;
    GetReg(An,Areg); GetReg(Am,Areg);
    src := An MOD 8; dst := Am MOD 8;
    Put16(SUBAL-LS8 + SP*LS9 + Dn);           (* SUBA.W   Dn.W,SP     *)
    Put16(MOVEAL + src*LS9 + AOFF + MP);      (* MOVEA.L  a(MP),An    *)
    Put16(a);
    Put16(MOVEL + Iea(AOFF+MP)*LS6 + ADIR+SP);(* MOVE.L   SP,a(MP)    *)
    Put16(a);                                 (* update descriptor    *)
    Put16(MOVEAL + dst*LS9 + ADIR + SP);      (* MOVEA.L  SP,Am       *)
    src := AINC + src; dst := AINC + dst;
    Put16(ASR + LS9 + word*LS6 + Dn);         (* Dn := Dn DIV 2       *)
    Put16(DEC1 + word*LS6 + Dn);              (* loop count in Dn     *)
    Put16(MOVEW + Iea(dst)*LS6 + src);     (* L: MOVE.W  (An)+,(Am)+ *)
    Put16(DBRA + Dn);                      (*    DBRA     Dn.W,L      *)
    Put16(177774B);
    Release(x);
    ReleaseReg(An);
    ReleaseReg(Am);
  END CopyDynArray;

  PROCEDURE EnterCase (VAR x : Item; base, lo, hi : INTEGER);
    (*  enter case-statement processor *)
    VAR m, n, z : Item; An : Register; xt : StrPtr;
  BEGIN
    WITH z DO
      (* transform z to 'prgMd' *)
      typ := inttyp; mode := prgMd; where := base;
    END (*WITH z*);
    xt := x.typ; (* hold original type of x *)
    LoadX(x,long); x.typ := dbltyp;
    LoadAdr(z); (* z.mode := RindMd; *)
    An := z.R MOD 8;
    IF (lo = 1) & (hi = 0) THEN (* if empty case *)
      Put16(JSR + AIDR + An)
    ELSE (* not-empty case *)
      SetconMd(m, lo, x.typ);
      ADD2(SUB,x,m);
      SetconMd(n, hi - lo, x.typ);
      Cmp2(x,n);
      Put16(BLS + 2);
      Put16(MOVEQ + x.R*LS9 + 377B); (* MOVEQ #-1,R *)
      SetconMd(m, 1D, inttyp);
      SHI2(ASL,x,m);
      Put16(MOVEW + x.R*LS9 + AIDX + An);
      IF x.wid = word THEN Put16(x.R*LS12) ELSE Put16(x.R*LS12 + LS11) END;
      Put16(JSR + AIDX + An);
      Put16(x.R*LS12)
    END;
    Release(z);
    Release(x);
    x.typ := xt; (* restore original type of x *)
  END EnterCase;

  PROCEDURE ExitCase;
    (*  leave case-statement *)
  BEGIN
    Put16(RTS);
  END ExitCase;

  PROCEDURE Link      (VAR l : INTEGER; lev : INTEGER);
    (* generate entry-code for procedure at level lev *)
  BEGIN
    IF lev = 0 THEN
      (* global procedure *)
      Put16(PUSHSB);                     (* MOVE.L  SB,-(SP)   *)
      Put16(MOVEAL + SB*LS9 + PREL);     (* MOVEA.L -d(PC),SB  *)
      Put16(-pc);                        (* points to relative address 0! *)
    END;
    (* global and local procedure *)
    Put16(LINK);                         (* LINK     MP,#local-data-size  *)
    l := pc;
    Put16(0);
  END Link;

  PROCEDURE Unlink    (parSize : INTEGER; lev : INTEGER);
    (* generate exit-code for procedure at level lev *)
  BEGIN
    Put16(UNLK);                         (* UNLK MP          *)
    IF lev = 0 THEN
      (* global procedure *)
      Put16(POPSB);                      (* MOVEA.L (SP)+,SB *)
    ELSE
     (* local procedure : include SL *)
     (* in the parameter size.       *)
      parSize := parSize + 4;
    END;
    IF parSize = 0 THEN Put16(RTS)       (* RTS              *)
    ELSE                                 (* or               *)
      Put16(RTD);                        (* RTD #parSize     *)
      Put16(parSize);
    END;
  END Unlink;

  PROCEDURE CallInt   (proc : ObjPtr);
    (* call of local procedure *)
  BEGIN
    WITH proc^ DO
      IF pd # NIL THEN
        Put16(BSR);
        Put16(pd^.adr - pc);
      END (*pd*);
    END (*WITH*);
  END CallInt;

  PROCEDURE CallExt   (proc : ObjPtr);
    (* call of external procedure *)
  BEGIN
    WITH proc^ DO
      IF pd # NIL THEN ExternalCall(pmod, pd^.num) END;
    END (*WITH*);
  END CallExt;

  PROCEDURE CallInd   (VAR x : Item);
    (* call of procedure variable *)
    VAR ea : INTEGER;
  BEGIN
    LoadP(x); x.mode := RindMd; (* transform 'AregMd' to 'RindMd' *)
    Gea(x,ea);
    Put16(JSR + ea);
    Ext(x);
    Release(x);
  END CallInd;

  PROCEDURE ExitModule;
  BEGIN
    Unlink(0,0);
  END ExitModule;

  PROCEDURE EnterModule;
    VAR dummy : INTEGER;
  BEGIN
    (* main module entry code : *)
    Link(dummy, 0);
    Put16(BSET + LS11 - LS8 + AOFF + SB); (* BSET     #0,-2(SB) *)
    Put16(0);
    Put16(-2);
    Put16(BEQ + 6);                       (* BEQ      +6        *)
    Unlink(0,0);                          (* exactly 6 Bytes!   *)
  END EnterModule;

  PROCEDURE InitModule(m : INTEGER);
  BEGIN
    ExternalCall(m, 0);
  END InitModule;


  (* The Floating-Point code generator : *)

  PROCEDURE fmt(VAR x : Item) : INTEGER;
    (* source specifier for <ea> : left shift by 10 is *)
    (* already included in the return value.           *)
    (* Note : do NOT allow for unsigned types !        *)
    VAR c : INTEGER; ftyp : StrPtr;
  BEGIN
    ftyp := x.typ;
    WHILE ftyp^.form = Range DO ftyp := ftyp^.RBaseTyp END;
    IF    ftyp = realtyp THEN c := 1 (* S *)
    ELSIF ftyp = lrltyp  THEN c := 5 (* D *)
    ELSIF ftyp = dbltyp  THEN c := 0 (* L *)
    ELSIF ftyp = inttyp  THEN c := 4 (* W *)
    ELSE err(241); c := 0;
    END;
    RETURN c*LS10
  END fmt;

  PROCEDURE MoveQuad(VAR x, y: Item);
    (* move quadword from memory x to memory y using the Integer Unit. *)
    CONST MOVEMSTD = 044300B; (* MOVEM.L  regs,ea *)
          MOVEMLDD = 046300B; (* MOVEM.L  ea,regs *)
          MOVELIMM = 020074B; (* MOVE.L   #imm,ea *)
          CLRLMSP  = 041247B; (* CLR.L    -(SP) *)
    VAR   ea : INTEGER;
  BEGIN
    IF (x.mode = conMd) & (y.mode = stkMd) THEN
      IF (x.val.D2 = 0) & (x.val.D3 = 0) THEN Put16(CLRLMSP)
      ELSE Put16(MOVELIMM + 7400B); Put16(x.val.D2); Put16(x.val.D3)
      END;
      IF (x.val.D = 0D) THEN Put16(CLRLMSP)
      ELSE Put16(MOVELIMM + 7400B); Put32(x.val.D);
      END
    ELSIF (x.mode # stkMd) OR (y.mode # stkMd) THEN
      IF x.mode = conMd THEN (* NO immediate's for MOVEM! *)
        IF (x.val.D = 0D) THEN Put16(MOVEQ + D0*LS9)
        ELSE Put16(MOVELIMM + D0*LS9); Put32(x.val.D);
        END;
        IF (x.val.D2 = 0) & (x.val.D3 = 0) THEN Put16(MOVEQ + D1*LS9)
        ELSE Put16(MOVELIMM + D1*LS9); Put16(x.val.D2); Put16(x.val.D3)
        END
      ELSE
        Gea(x,ea);
        Put16(MOVEMLDD + ea); Put16(3);  (* for D0/D1 *)
        Ext(x);
        Release(x);
      END;
      IF y.mode = stkMd THEN
        Put16(MOVEMDEC); Put16(140000B); (* for D0/D1 *)
      ELSE
        Gea(y,ea);
        Put16(MOVEMSTD + ea); Put16(3);  (* for D0/D1 *)
        Ext(y);
      END
    END
  END MoveQuad;

  PROCEDURE FMove(VAR x, y : Item);
    (* floating move x to y. *)
    VAR Fn : Register; ea, sz : INTEGER;
  BEGIN
    sz := y.typ^.size;
    IF y.mode = fltMd THEN
      (* load to floating-point register : *)
      Fn := y.FR;
      IF x.mode = fltMd THEN (* FMOVE.X  Fm,Fn *)
        IF x.FR # Fn THEN
          Put16(FGEN);
          Put16(FtoF + x.FR*LS10 + Fn*LS7);
        END;
      ELSIF x.mode <= DregMd THEN (* FMOVE.<fmt> <ea>,Fn *)
        IF x.mode = AregMd THEN LoadD(x) END;
        Gea(x,ea);
        Put16(FGEN + ea);
        Put16(EAtoF + fmt(x) + Fn*LS7);
        Ext(x);
      ELSE err(245)
      END;
    ELSIF x.mode = fltMd THEN
      (* store from floating-point register : *)
      Fn := x.FR;
      IF y.mode <= DregMd THEN (* FMOVE.<fmt> Fn,<ea> *)
        IF (y.mode = AregMd) OR (y.mode = conMd) THEN err(285) END;
        IF (y.mode = stkMd) THEN ea := 47B (* gives -(SP) *)
        ELSE Gea(y,ea) END;
        Put16(FGEN + ea);
        Put16(FtoEA + fmt(y) + Fn*LS7);
        Ext(y);
        IF y.mode = DregMd THEN y.wid := long;
          (* equivalent to a LoadD-operation :   *)
          (* set the width of the result stored. *)
          IF sz > 4 THEN err(285)
          ELSE y.wid := sz DIV 2 END;
        END;
      ELSE err(245)
      END;
    ELSIF x.typ = y.typ THEN
      (* move identical types from <ea> to <ea> : *)
      IF sz <= 4 THEN Move(x,y)
      ELSIF (sz = 8) & (x.mode <= stkMd) & (y.mode <= stkMd) THEN MoveQuad(x,y)
      ELSE err(245)
      END;
    ELSE
      (* move NON-identical types : *)
      LoadF(x);   (* load x into floating point reg. *)
      FMove(x,y); (* re-call *)
    END;
  END FMove;

  PROCEDURE LoadF(VAR x : Item);
    (* load x into a floating-point register : *)
    VAR Fn : Register; y : Item;
  BEGIN
    IF x.mode <= DregMd THEN
      GetFReg(Fn);
      SetfltMd(y, Fn, x.typ);
      FMove(x,y);
      Release(x);
      x := y;
    ELSIF x.mode # fltMd THEN
      err(241); Release(x);
      SetfltMd(x, F0, x.typ);
    END;
  END LoadF;

  PROCEDURE FOp1(op : INTEGER; VAR x : Item);
    VAR Fn : Register; ea : INTEGER;
  BEGIN
    IF x.mode = fltMd THEN
      (* Fop.X   FPn *)
      IF op # FTST THEN Fn := x.FR ELSE Fn := 0 END;
      Put16(FGEN);
      Put16(FtoF + x.FR*LS10 + Fn*LS7 + op);
      (* the same source and dest. register! *)
    ELSE
      (* Fop.<fmt>  <ea>,FPn *)
      IF op # FTST THEN GetFReg(Fn) ELSE Fn := 0 END;
      IF x.mode = AregMd THEN LoadD(x) END;
      Gea(x,ea);
      Put16(FGEN + ea);
      Put16(EAtoF + fmt(x) + Fn*LS7 + op);
      Ext(x);
      Release(x); (* free the old registers! *)
      (* resulting mode is 'fltMd' : *)
      x.mode := fltMd; x.FR := Fn;
    END;
  END FOp1;

  PROCEDURE FOp2(op : INTEGER; VAR x, y : Item);
    VAR ea : INTEGER;
  BEGIN
    LoadF(x); (* resulting mode is 'fltMd' *)
    IF y.mode = fltMd THEN
      (* Fop.X   FPm,FPn *)
      Put16(FGEN);
      Put16(FtoF + y.FR*LS10 + x.FR*LS7 + op);
    ELSE
      (* Fop.<fmt>  <ea>,FPn *)
      IF x.mode = AregMd THEN LoadD(x) END;
      Gea(y,ea);
      Put16(FGEN + ea);
      Put16(EAtoF + fmt(y) + x.FR*LS7 + op);
      Ext(y);
    END;
    Release(y); (* free y's registers! *)
  END FOp2;

  PROCEDURE FMonad(op : FMonadic; VAR x : Item);
    (* interface to the MC68040 monadic operators : *)
    VAR cd : INTEGER; Dn : Register; y : Item;
  BEGIN
    cd := 200B; (* indicates NO FOp1-call *)
    CASE op OF
    | Abs :           cd := FABS;
    | NonStand :      cd := FNEG;
    | Sqrt :          cd := FSQRT;
    | Float :         cd := FMOVE; (* INC(cd, 64); *)                  (* RPsbI *)
    | FloatD :        cd := FMOVE; (* INC(cd, 68); *)                  (* RPsbI *)
    | Long :          cd := FMOVE; (* INC(cd, 68); *)                  (* RPsbI *)
    | Short :         cd := FMOVE; (* INC(cd, 64); *)                  (* RPsbI *)
    | Trunc, TruncD,
      Entier, Round : LoadF(x);
                      Put16(FGEN + D1); (* save FPCR to D1 *)
                      Put16(CRtoEA);
                      Put16(MOVEL + D1);
                      Put16(ANDI + D0); Put16(317B);
                      Put16(ORI + D0);
                      IF op = Round THEN Put16(0)
                      ELSIF op = Entier THEN Put16(40B)
                      ELSE Put16(20B) END;
                      Put16(FGEN + D0);
                      Put16(EAtoCR);
                      GetReg(Dn,Dreg);
                      IF op = Trunc THEN SetregMd(y,Dn,inttyp)
                      ELSE SetregMd(y,Dn,dbltyp) END;
                      FMove(x,y);       (* FMOVE FPm,Dn *)
                      Release(x);
                      x := y;
                      Put16(FGEN + D1); (* restore D1 to FPCR *)
                      Put16(EAtoCR);
    ELSE              err(200);
    END (*CASE*);
    IF cd < 200B THEN
      (* RPsbI : Rounding-Precision specified by Instruction :
      IF (cd = FABS) OR (cd = FNEG) OR (cd = FSQRT) THEN               (* RPsbI *)
        IF (cd = FSQRT) THEN cd := 1 END;                              (* RPsbI *)
        IF (x.typ = realtyp) THEN INC(cd, 64) ELSE INC(cd, 68) END;    (* RPsbI *)
      END;                                                             (* RPsbI *)
      *)
      FOp1(cd,x);
    END;
  END FMonad;

  PROCEDURE FDyad(op : FDyadic; VAR x, y : Item);
    (* interface to the MC68040 dyadic operators : *)
    VAR cd : INTEGER;
  BEGIN
    cd := 200B; (* indicates NO FOp2-call *)
    CASE op OF
    | plus  :         cd := FADD;
    | minus :         cd := FSUB;
    | times :         cd := FMUL;
    | slash :         cd := FDIV; IF ZeroVal(y) THEN err(205) END;
    | eql .. geq :    cd := FCMP; IF ZeroVal(y) THEN cd := FTST END;
    ELSE              err(200);
    END (*CASE*);
    IF cd = FTST THEN FOp1(FTST,x)
    ELSIF cd < 200B THEN
      (* RPsbI : Rounding-Precision specified by Instruction :
      IF (cd = FADD) OR (cd = FSUB) OR (cd = FMUL) OR (cd = FDIV) THEN (* RPsbI *)
        IF (x.typ = realtyp) THEN INC(cd, 64) ELSE INC(cd, 68) END;    (* RPsbI *)
      END;                                                             (* RPsbI *)
      *)
      FOp2(cd,x,y);
    END;
    Release(y);
  END FDyad;


END M2HA. (* Copyright Departement Informatik, ETH Zuerich, Switzerland, 1992 *)